From 9314cff9292b15bcd20d685245b928df0f75f70c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 21 Jul 2010 16:19:12 -0600 Subject: [PATCH 001/462] change mrlib/image-core to use pen-list% cap and join support original commit: 5d7f04448802ef955c59cd68d47ed667652f2783 --- collects/mrlib/image-core.rkt | 31 ++++++------------------------- 1 file changed, 6 insertions(+), 25 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9e474ebb..9608c082 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -947,32 +947,13 @@ the mask bitmap and the original bitmap are all together in a single bytes! (color-blue color)))) -(define pen-ht (make-hash)) - (define (pen->pen-obj/cache pen) - (cond - [(and (equal? 'round (pen-join pen)) - (equal? 'round (pen-cap pen))) - (send the-pen-list find-or-create-pen - (pen-color pen) - (pen-width pen) - (pen-style pen))] - [else - (let* ([wb/f (hash-ref pen-ht pen #f)] - [pen-obj/f (and (weak-box? wb/f) (weak-box-value wb/f))]) - (or pen-obj/f - (let ([pen-obj (pen->pen-obj pen)]) - (hash-set! pen-ht pen (make-weak-box pen-obj)) - pen-obj)))])) - -(define (pen->pen-obj pen) - (let ([ans (make-object pen% - (pen-color pen) - (pen-width pen) - (pen-style pen))]) - (send ans set-cap (pen-cap pen)) - (send ans set-join (pen-join pen)) - ans)) + (send the-pen-list find-or-create-pen + (pen-color pen) + (pen-width pen) + (pen-style pen) + (pen-cap pen) + (pen-join pen))) (define (to-img arg) (cond From 670939a193bb334653f75893142148183fb9dea3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 20 Jul 2010 22:59:03 -0500 Subject: [PATCH 002/462] fixed a bug in the saving of bitmaps (and along the way added some randomized tests that found a few other things) Please merge to release branch. (cherry picked from commit 6cd277a36fe6f8eba4cb02f46a8c8ea98f036802) original commit: c9e6f5d3155763a5210a43e3fcd275539c241d81 --- collects/mrlib/image-core.rkt | 48 +++++++++++++++----- collects/mrlib/private/image-core-bitmap.rkt | 6 ++- 2 files changed, 41 insertions(+), 13 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 63b21dbb..9e474ebb 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -150,7 +150,8 @@ has been moved out). ;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%))) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods (define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable]) - #:omit-define-syntaxes #:transparent) + #:omit-define-syntaxes #:transparent + #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) ;; a flip is: ;; - (make-flip boolean bitmap) @@ -158,7 +159,7 @@ has been moved out). ;; * this struct is here to avoid adding a field to bitmaps, so that old save files ;; from when the library did not support flipping still load ;; (since normalization will add a flip structure if necessary) -(define-struct/reg-mk flip (flipped? shape)) +(define-struct/reg-mk flip (flipped? shape) #:transparent) ;; a polygon is: ;; @@ -312,7 +313,7 @@ has been moved out). (define/override (find-scroll-step y) (calc-scroll-step) (inexact->exact (ceiling (/ y scroll-step)))) - + (define/override (copy) (make-image shape bb normalized?)) (define/override (draw dc x y left top right bottom dx dy draw-caret?) (let ([smoothing (send dc get-smoothing)]) @@ -342,8 +343,8 @@ has been moved out). (and (= (round (bb-right bb1)) (round (bb-right bb2))) (= (round (bb-bottom bb1)) (round (bb-bottom bb2))) (= (round (bb-baseline bb1)) (round (bb-baseline bb2))))) -(define racket/base:read read) +(define racket/base:read read) (define image-snipclass% (class snip-class% (define/override (read f) @@ -370,7 +371,7 @@ has been moved out). (provide snip-class) (define snip-class (new image-snipclass%)) -(send snip-class set-classname (format "~s" '(lib "image-core.ss" "2htdp" "private"))) +(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib"))) (send snip-class set-version 1) (send (get-the-snip-class-list) add snip-class) @@ -384,12 +385,17 @@ has been moved out). [(vector? sexp) (if (= (vector-length sexp) 0) (k #f) - (let ([constructor (id->constructor (vector-ref sexp 0))] - [args (cdr (vector->list sexp))]) - (if (and constructor - (procedure-arity-includes? constructor (length args))) - (apply constructor (map loop args)) - (k #f))))] + (cond + [(bytes? (vector-ref sexp 0)) + ;; bitmaps are vectors with a bytes in the first field + (apply bytes->bitmap (vector->list sexp))] + [else + (let ([constructor (id->constructor (vector-ref sexp 0))] + [args (cdr (vector->list sexp))]) + (if (and constructor + (procedure-arity-includes? constructor (length args))) + (apply constructor (map loop args)) + (k #f)))]))] [else sexp])))) (define-id->constructor id->constructor) @@ -829,7 +835,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (let-values ([(rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ)]) (let* ([flipped-bytes (if flip? - (flip-bytes rotated-bytes w h) + (flip-bytes rotated-bytes rotated-w rotated-h) rotated-bytes)] [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] [mask (send bm get-loaded-mask)]) @@ -1005,6 +1011,24 @@ the mask bitmap and the original bitmap are all together in a single bytes! (make-bb w h h) #f))) +(define (bitmap-write bitmap port mode) + (let* ([v (struct->vector bitmap)] + [recur (case mode + [(#t) write] + [(#f) display] + [else (lambda (p port) (print p port mode))])] + [update + (λ (i) + (let ([o (vector-ref v i)]) + (let ([nv (call-with-values (λ () (bitmap->bytes o)) vector)]) + (vector-set! v i nv))))]) + (update 1) + (update 2) + ;; don't save the rendered bitmap (if it is there) + (vector-set! v 6 #f) + (vector-set! v 7 #f) + (recur v port))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 200429fe..7b6b2baf 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -67,7 +67,11 @@ instead of this scaling code, we use the dc<%>'s scaling code. (define (bytes->bitmap bytes w h) (unless (= (bytes-length bytes) (* w h NUM-CHANNELS)) - (error 'bytes->bitmap "wrong sizes")) + (error 'bytes->bitmap "wrong sizes, got ~a bytes, w ~a h ~a (which should be ~a bytes)" + (bytes-length bytes) + w + h + (* w h NUM-CHANNELS))) (let* ([bm (make-object bitmap% w h)] [mask (make-object bitmap% w h)] [bdc (make-object bitmap-dc% bm)]) From c012472a6288369ee5b20a79d6745f12c955292b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 21 Jul 2010 16:19:12 -0600 Subject: [PATCH 003/462] change mrlib/image-core to use pen-list% cap and join support (cherry picked from commit 5d7f04448802ef955c59cd68d47ed667652f2783) original commit: ba8ec17d8837a86643f058431344470ddd737398 --- collects/mrlib/image-core.rkt | 31 ++++++------------------------- 1 file changed, 6 insertions(+), 25 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9e474ebb..9608c082 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -947,32 +947,13 @@ the mask bitmap and the original bitmap are all together in a single bytes! (color-blue color)))) -(define pen-ht (make-hash)) - (define (pen->pen-obj/cache pen) - (cond - [(and (equal? 'round (pen-join pen)) - (equal? 'round (pen-cap pen))) - (send the-pen-list find-or-create-pen - (pen-color pen) - (pen-width pen) - (pen-style pen))] - [else - (let* ([wb/f (hash-ref pen-ht pen #f)] - [pen-obj/f (and (weak-box? wb/f) (weak-box-value wb/f))]) - (or pen-obj/f - (let ([pen-obj (pen->pen-obj pen)]) - (hash-set! pen-ht pen (make-weak-box pen-obj)) - pen-obj)))])) - -(define (pen->pen-obj pen) - (let ([ans (make-object pen% - (pen-color pen) - (pen-width pen) - (pen-style pen))]) - (send ans set-cap (pen-cap pen)) - (send ans set-join (pen-join pen)) - ans)) + (send the-pen-list find-or-create-pen + (pen-color pen) + (pen-width pen) + (pen-style pen) + (pen-cap pen) + (pen-join pen))) (define (to-img arg) (cond From dbed637bfef4275d3238a1494c992458172c9f2c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 28 Jul 2010 15:13:05 -0500 Subject: [PATCH 004/462] from commentary following up in PR 11054 original commit: 2309856e2a18e36c5bbedac346cd009ef798b3ad --- collects/framework/private/frame.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 46c89c73..9cff2880 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -1807,7 +1807,7 @@ [bt (box 0)] [bb (box 0)]) (send text get-visible-line-range bt bb #f) - (unless (<= (unbox bt) search-result-line (unbox bb)) + (unless (< (unbox bt) search-result-line (unbox bb)) (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] [last-pos (send text position-line (send text last-position))] [top-pos (send text line-start-position From b5ffd1cf21ff036bc90d43f633e9fce88a267bec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 06:56:16 -0500 Subject: [PATCH 005/462] fix doc typo original commit: 78751b982a359855ffa48e3bedac9425dc980068 --- collects/scribblings/gui/blurbs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/blurbs.rkt b/collects/scribblings/gui/blurbs.rkt index 577c399e..ae2818d6 100644 --- a/collects/scribblings/gui/blurbs.rkt +++ b/collects/scribblings/gui/blurbs.rkt @@ -63,7 +63,7 @@ handling an unspecified number of events; the menu may still be popped up when this method returns. If a menu item is selected from the popup-menu, the callback for the menu item is called. (The - eventspace for menu item's callback is the @|what|'s eventspace.)} + eventspace for the menu item's callback is the @|what|'s eventspace.)} @p{While the menu is popped up, its target is set to the @|other|. See @method[popup-menu% get-popup-target] From 3b9a210cdb74e3a682111bbd31129e99b8c92d52 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 31 Jul 2010 07:49:37 -0500 Subject: [PATCH 006/462] closes PR 11065 original commit: 1b25f2241fe2b7e4d77307f009f56423cb996e2f --- collects/framework/private/main.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 893c5de6..f15e294d 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -261,7 +261,7 @@ parameterize call-with-input-file call-with-input-file* with-input-from-file with-input-from-port call-with-output-file - with-output-to-file with-output-to-port + with-output-to-file with-output-to-port with-output-to-string for-all )) From db4c5300202c9f589ad840710c36140781abde1d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 31 Jul 2010 09:39:44 -0500 Subject: [PATCH 007/462] whoops, PR 11065 was wrong original commit: d2802a0ed7db9286cfa768282cde609717947d13 --- collects/framework/private/main.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index f15e294d..c8f8c3d0 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -261,7 +261,7 @@ parameterize call-with-input-file call-with-input-file* with-input-from-file with-input-from-port call-with-output-file - with-output-to-file with-output-to-port with-output-to-string + with-output-to-file with-output-to-port for-all )) From 7c5fa6e851caf0ec264e844e08dd718c526c4caa Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 2 Aug 2010 13:01:27 -0500 Subject: [PATCH 008/462] fixed a bug reported by Todd on the mailing list (probably this is his bug anyways) original commit: f79336058620fb4d44a924af211f3a8fef5bacb4 --- collects/mrlib/image-core.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9608c082..73392117 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1001,7 +1001,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! [update (λ (i) (let ([o (vector-ref v i)]) - (let ([nv (call-with-values (λ () (bitmap->bytes o)) vector)]) + (let ([nv (and o + (call-with-values (λ () (bitmap->bytes o)) vector))]) (vector-set! v i nv))))]) (update 1) (update 2) From 286312cf28f2b09a2e3364efaf5061e97ecdc422 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 2 Aug 2010 13:01:27 -0500 Subject: [PATCH 009/462] fixed a bug reported by Todd on the mailing list (probably this is his bug anyways) (cherry picked from commit f79336058620fb4d44a924af211f3a8fef5bacb4) original commit: 2c77ae5e3c9bb7ff89b4e9da70c1b06f657f2f52 --- collects/mrlib/image-core.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9608c082..73392117 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1001,7 +1001,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! [update (λ (i) (let ([o (vector-ref v i)]) - (let ([nv (call-with-values (λ () (bitmap->bytes o)) vector)]) + (let ([nv (and o + (call-with-values (λ () (bitmap->bytes o)) vector))]) (vector-set! v i nv))))]) (update 1) (update 2) From 100ff15c0057b466202518dccfafd325643fe673 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 12:34:06 -0600 Subject: [PATCH 010/462] add methods to text-field% to control the background color original commit: c8762ae87724b8a52056929bad6554d08f79dd0f --- collects/mred/private/mrtextfield.rkt | 7 ++++++- collects/mred/private/wxtextfield.rkt | 7 ++++++- collects/scribblings/gui/text-field-class.scrbl | 11 +++++++++++ 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index 179b9b46..e76c938c 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -57,11 +57,16 @@ (private-field [wx #f]) (public + [set-field-background (lambda (c) + (check-instance '(method text-field% set-field-color) + wx:color% 'color% #f c) + (send wx set-field-background c))] + [get-field-background (lambda () (send wx get-field-background))] [get-editor (entry-point (lambda () (send wx get-editor)))] [get-value (lambda () (send wx get-value))] ; note: wx method doesn't expect as-entry [set-value (entry-point (lambda (v) - (check-string '(method text-control<%> set-value) v) + (check-string '(method text-field% set-value) v) (send wx set-value v)))]) (sequence ;; Technically a bad way to change margin defaults, since it's diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index f17688bb..55a0b2f3 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -113,7 +113,12 @@ [get-canvas-width (lambda () (let ([tw (box 0)]) (send c get-size tw (box 0)) - (unbox tw)))]) + (unbox tw)))] + + [set-field-background (lambda (col) + (send c set-canvas-background col))] + [get-field-background (lambda () + (send c get-canvas-background))]) (override ;; These might be called before we are fully initialized diff --git a/collects/scribblings/gui/text-field-class.scrbl b/collects/scribblings/gui/text-field-class.scrbl index 3519d102..3032ca10 100644 --- a/collects/scribblings/gui/text-field-class.scrbl +++ b/collects/scribblings/gui/text-field-class.scrbl @@ -116,6 +116,11 @@ For a text field, the most useful methods of a @scheme[text%] object } +@defmethod[(get-field-background) (is-a?/c color%)]{ + +Gets the background color of the field's editable area.} + + @defmethod[(get-value) string?]{ @@ -124,6 +129,12 @@ Returns the text currently in the text field. } +@defmethod[(set-field-background [color (is-a?/c color%)]) + void?]{ + +Sets the background color of the field's editable area.} + + @defmethod[(set-value [val string?]) void?]{ From 916cdf4dc192a92bfa2b2ca9488871539d1852f3 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 13 Aug 2010 10:13:33 -0400 Subject: [PATCH 011/462] updated framework test framework: - can now test multi-key sequences - can now use tests with 'escape - README changed .ss to .rkt - added test cases for c:c;c:[ original commit: cfe503f1cecb93a0fb1c6a93d6eaabdb845025ff --- collects/framework/test.rkt | 3 +- collects/tests/framework/README | 30 +++---- collects/tests/framework/keys.rkt | 128 ++++++++++++++++++++++++------ collects/tests/framework/main.rkt | 5 +- 4 files changed, 126 insertions(+), 40 deletions(-) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 03f49d35..ac0c21c7 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -466,7 +466,8 @@ 'noalt 'nocontrol 'nometa 'noshift)) (define valid-key-symbols - (list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital + (list 'escape ;; just trying this for the heck of it -- JBC, 2010-08-13 + 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital 'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print 'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2 'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9 diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 60f808df..591d3f28 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -13,9 +13,9 @@ gracket to exit in order to pass, this governor is required. To run a test use: - framework-test ... + framework-test ... -where is the name of one of the tests below. Alternatively, +where is the name of one of the tests below. Alternatively, pass no command-line arguments to run all of the tests. Some of the tests in this file are not yet present in the @@ -26,17 +26,17 @@ OS X: you will have to click on the newly started gracket processes in the doc while the test suite runs or it will signal failures when there aren't any. -- load: |# load.ss #| +- load: |# load.rkt #| | This tests that the advertised ways of loading the framework at | it's components all work. -- exit: |# exit.ss #| +- exit: |# exit.rkt #| | This tests that exit:exit really exits and that the exit callbacks | are actually run. -- preferences: |# prefs.ss #| +- preferences: |# prefs.rkt #| | This tests that preferences are saved and restored correctly, both | immediately and across reboots of gracket. @@ -48,20 +48,20 @@ signal failures when there aren't any. | Each test assumes that the others pass; this may yield strange | error messages when one fails. - - frames: |# frame.ss #| - - canvases: |# canvas.ss #| - - texts: |# text.ss #| - - pasteboards: |# pasteboard.ss #| + - frames: |# frame.rkt #| + - canvases: |# canvas.rkt #| + - texts: |# text.rkt #| + - pasteboards: |# pasteboard.rkt #| -- keybindings: |# keys.ss #| +- keybindings: |# keys.rkt #| | This tests the misc (non-scheme) keybindings -- searching: |# search.ss #| +- searching: |# search.rkt #| | This tests the search results -- group tests: |# group-test.ss #| +- group tests: |# group-test.rkt #| | make sure that mred:the-frame-group records frames correctly. | fake user input expected. @@ -75,15 +75,15 @@ signal failures when there aren't any. | Tests the scheme: section - |# scheme.ss #| + |# scheme.rkt #| - |# (interactive #| tests | these tests require intervention by people. Clicking and whatnot - - panel:single |# panel.ss #| + - panel:single |# panel.rkt #| - - garbage collection: |# mem.ss #| + - garbage collection: |# mem.rkt #| | These tests will create objects in various configurations and | make sure that they are garbage collected diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt index 3d244263..95253d76 100644 --- a/collects/tests/framework/keys.rkt +++ b/collects/tests/framework/keys.rkt @@ -80,16 +80,32 @@ (test-canonicalize 11 "esc;s:a" "esc;s:a") (test-canonicalize 12 "s:a;esc" "s:a;esc") + + ;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?)) + ;; a key-spec represents a test case for a key; 'before' contains the + ;; content of a buffer, and 'after' represents the desired content of the + ;; buffer after the keypress. The keypress(es) in question are specified + ;; independently for the three platforms by the respective 'macos', 'unix', + ;; and 'windows' fields. (define-struct key-spec (before after macos unix windows)) + + ;; an abstraction to use when all platforms have the same sequence of keys + (define (make-key-spec/allplatforms before after keys) + (make-key-spec before after keys keys keys)) + + ;; a buff-spec is (make-buff-spec string nat nat) + ;; a buff-spec represents a buffer state; the content of the buffer, + ;; and the start and end of the highlighted region. (define-struct buff-spec (string start end)) + ;; the keybindings test cases applied to frame:text% editors (define global-specs (list (make-key-spec (make-buff-spec "abc" 1 1) (make-buff-spec "abc" 2 2) - (list '(#\f control) '(right)) - (list '(#\f control) '(right)) - (list '(#\f control) '(right))))) + (list '((#\f control)) '((right))) + (list '((#\f control)) '((right))) + (list '((#\f control)) '((right)))))) (define (build-open-bracket-spec str pos char) (make-key-spec (make-buff-spec str pos pos) @@ -99,22 +115,23 @@ (substring str pos (string-length str))) (+ pos 1) (+ pos 1)) - (list (list #\[)) - (list (list #\[)) - (list (list #\[)))) + (list (list (list #\[))) + (list (list (list #\[))) + (list (list (list #\[))))) + ;; the keybindings test cases applied to scheme:text% editors (define scheme-specs (list (make-key-spec (make-buff-spec "(abc (def))" 4 4) (make-buff-spec "(abc (def))" 10 10) - (list '(right alt)) - (list '(right alt)) - (list '(right alt))) + (list '((right alt))) + (list '((right alt))) + (list '((right alt)))) (make-key-spec (make-buff-spec "'(abc (def))" 1 1) (make-buff-spec "'(abc (def))" 12 12) - (list '(right alt)) - (list '(right alt)) - (list '(right alt))) + (list '((right alt))) + (list '((right alt))) + (list '((right alt)))) #| (make-key-spec (make-buff-spec "'(abc (def))" 0 0) (make-buff-spec "'(abc (def))" 12 12) @@ -159,36 +176,101 @@ (build-open-bracket-spec "(let ([])(" 10 #\() (build-open-bracket-spec "(local " 7 #\[) (build-open-bracket-spec "(local []" 9 #\() + ;; test to show that multi-keystrokes works: + (make-key-spec/allplatforms + (make-buff-spec "" 0 0) + (make-buff-spec "zx" 2 2) + (list '((#\z) (#\x)))) + ;; remove-enclosing-parens : + (make-key-spec/allplatforms + (make-buff-spec "(abc def)" 1 1) + (make-buff-spec "abc" 0 0) + (list '((#\c control) (#\o control)))) + ;; (is this the desired behavior?): + (make-key-spec/allplatforms + (make-buff-spec "(abc def)" 2 3) + (make-buff-spec "bc" 0 0) + (list '((#\c control) (#\o control)))) + ;; insert-()-pair : + (make-key-spec/allplatforms + (make-buff-spec "abc" 0 0) + (make-buff-spec "()abc" 1 1) + (list '((escape) (#\()))) + (make-key-spec/allplatforms + (make-buff-spec "abc" 0 2) + (make-buff-spec "(ab)c" 1 1) + (list '((escape) (#\()))) + ;; toggle-square-round-parens : + ; () -> [] + (make-key-spec/allplatforms + (make-buff-spec "(a)" 0 0) + (make-buff-spec "[a]" 0 0) + (list '((#\c control) (#\[ control)))) + ; [] -> () + (make-key-spec/allplatforms + (make-buff-spec "[a]" 0 0) + (make-buff-spec "(a)" 0 0) + (list '((#\c control) (#\[ control)))) + ; enclosed sexps + (make-key-spec/allplatforms + (make-buff-spec "[a (def )b]" 0 0) + (make-buff-spec "(a (def )b)" 0 0) + (list '((#\c control) (#\[ control)))) + ; extra preceding whitespace + (make-key-spec/allplatforms + (make-buff-spec " \n [a (def )b]" 0 0) + (make-buff-spec " \n (a (def )b)" 0 0) + (list '((#\c control) (#\[ control)))) + ; cursor not at beginning of buffer + (make-key-spec/allplatforms + (make-buff-spec " \n [a (def )b]" 1 1) + (make-buff-spec " \n (a (def )b)" 1 1) + (list '((#\c control) (#\[ control)))) + ; intervening non-paren sexp + (make-key-spec/allplatforms + (make-buff-spec " \nf [a (def )b]" 1 1) + (make-buff-spec " \nf [a (def )b]" 1 1) + (list '((#\c control) (#\[ control)))) + ;; at end of buffer (hence sexp-forward returns #f): + (make-key-spec/allplatforms + (make-buff-spec "[a]" 3 3) + (make-buff-spec "[a]" 3 3) + (list '((#\c control) (#\[ control)))) )) (send-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t)) (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) (wait-for-frame "dummy to trick frame group") + ;; test-key : key-spec -> + ;; evaluates a test case represented as a key-spec (define (test-key key-spec) - (let* ([keys ((case (system-type) - [(macos macosx) key-spec-macos] - [(unix) key-spec-unix] - [(windows) key-spec-windows]) - key-spec)] + (let* ([key-sequences + ((case (system-type) + [(macos macosx) key-spec-macos] + [(unix) key-spec-unix] + [(windows) key-spec-windows]) + key-spec)] [before (key-spec-before key-spec)] [after (key-spec-after key-spec)] - [process-key - (lambda (key) + [process-key-sequence + (lambda (key-sequence) (let ([text-expect (buff-spec-string after)] [start-expect (buff-spec-start after)] [end-expect (buff-spec-end after)]) - (test key + (test key-sequence (lambda (x) (equal? x (vector text-expect start-expect end-expect))) `(let* ([text (send (get-top-level-focus-window) get-editor)]) (send text erase) (send text insert ,(buff-spec-string before)) (send text set-position ,(buff-spec-start before) ,(buff-spec-end before)) - (test:keystroke ',(car key) ',(cdr key)) + ,@(map (lambda (key) `(test:keystroke ',(car key) ',(cdr key))) + key-sequence) (vector (send text get-text) (send text get-start-position) (send text get-end-position))))))]) - (for-each process-key keys))) + (for-each process-key-sequence key-sequences))) + (define (test-specs frame-name frame-class specs) (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) @@ -196,7 +278,7 @@ (for-each test-key specs) (send-sexp-to-mred `(send (get-top-level-focus-window) close))) - (test-specs "global keybingings test" 'frame:text% global-specs) + (test-specs "global keybindings test" 'frame:text% global-specs) (test-specs "scheme mode keybindings test" '(class frame:editor% (define/override (get-editor%) scheme:text%) diff --git a/collects/tests/framework/main.rkt b/collects/tests/framework/main.rkt index d94f3a78..b1e3bb24 100644 --- a/collects/tests/framework/main.rkt +++ b/collects/tests/framework/main.rkt @@ -48,7 +48,10 @@ "framework-test" (current-command-line-arguments) command-line-flags (lambda (collected . files) (when (null? files) (set! batch? #t)) - (let ([files (filter (lambda (x) (member x all-files)) files)]) + (let* ([throwouts (remove* all-files files)] + [files (remove* throwouts files)]) + (when (not (null? throwouts)) + (debug-printf admin " ignoring files that don't occur in all-files: ~s\n" throwouts)) (set! files-to-process (cond [all? all-files] [batch? (remove* interactive-files all-files)] From 7643ce1197703f6a7cd333674aa52ad9195d07a6 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 13 Aug 2010 10:54:30 -0400 Subject: [PATCH 012/462] best guess on what keystrokes will trigger insert-()-pair under windows & unix. original commit: 215c8dc96070890e81193393b2e78265bd1691a6 --- collects/tests/framework/keys.rkt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt index 95253d76..6ba89dec 100644 --- a/collects/tests/framework/keys.rkt +++ b/collects/tests/framework/keys.rkt @@ -192,13 +192,17 @@ (make-buff-spec "bc" 0 0) (list '((#\c control) (#\o control)))) ;; insert-()-pair : - (make-key-spec/allplatforms + (make-key-spec (make-buff-spec "abc" 0 0) (make-buff-spec "()abc" 1 1) + (list '((escape) (#\())) + (list '((#\( meta))) (list '((escape) (#\()))) - (make-key-spec/allplatforms + (make-key-spec (make-buff-spec "abc" 0 2) (make-buff-spec "(ab)c" 1 1) + (list '((escape) (#\())) + (list '((#\( meta))) (list '((escape) (#\()))) ;; toggle-square-round-parens : ; () -> [] From fa10a602087473246fedaaa680b8d85c54aa65b4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Aug 2010 10:40:14 -0500 Subject: [PATCH 013/462] added for/fold to square-bracket default prefs original commit: 672355f82343bd73efa11877cc6c2f8234a2da1d --- collects/framework/private/main.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index c8f8c3d0..b70d6f85 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -76,7 +76,7 @@ '("local") (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:square-bracket:letrec - (let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) + (let ([fors '("for" "for/fold" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) (append fors (map (λ (x) (regexp-replace #rx"for" x "for*")) fors) From fe82be3d45345cdd90da7a6114d1c72799f2243e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 24 Aug 2010 13:45:53 -0500 Subject: [PATCH 014/462] Adjusts the prompt handling so that it submits expressions that signal arbitrary read errors, but does not submit those that raise eof errors. closes PR 11126 original commit: 5de6ff2ada89c94e0f854dfd44e95471b6df0dc5 --- collects/framework/main.rkt | 7 +++++-- collects/framework/private/scheme.rkt | 15 +++++++++------ collects/tests/framework/scheme.rkt | 7 ++++--- 3 files changed, 18 insertions(+), 11 deletions(-) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 7568e710..c4e3fe8b 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -1327,10 +1327,13 @@ @scheme[end] in @scheme[text] has at least one complete s-expression and there are no incomplete s-expressions. If @scheme[end] is @scheme[#f], it defaults to the last position of the - @scheme[text]. + @scheme[text]. The designation ``complete'' is defined to be something that does not + cause @racket[read] to raise a @racket[exn:fail:read:eof?] exception, + so there may be all kinds of strange read-level (not to speak of parse level) + errors in the expressions. The implementation of this function creates a port with - @scheme[open-input-text-editor] and then uses `read' to parse the + @scheme[open-input-text-editor] and then uses @racket[read] to parse the range of the buffer.}) (proc-doc/names diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index 836d1e8e..07e72d92 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -44,13 +44,16 @@ (let* ([end (or in-end (send text last-position))] [port (open-input-text-editor text start end)]) (with-handlers ([exn:fail:read:eof? (λ (x) #f)] - [exn:fail:read? (λ (x) #f)]) + [exn:fail:read? (λ (x) #t)]) (let ([first (read port)]) - (and (not (eof-object? first)) - (let loop () - (let ([s (read port)]) - (or (eof-object? s) - (loop)))))))))) + (cond + [(eof-object? first) #f] + [else + (let loop () + (let ([s (read port)]) + (cond + [(eof-object? s) #t] + [else (loop)])))])))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; diff --git a/collects/tests/framework/scheme.rkt b/collects/tests/framework/scheme.rkt index c31c5cc6..6f5129a6 100644 --- a/collects/tests/framework/scheme.rkt +++ b/collects/tests/framework/scheme.rkt @@ -21,10 +21,11 @@ (test-text-balanced? 0 "" 0 #f #f) (test-text-balanced? 1 " \n " 0 #f #f) -(test-text-balanced? 2 "foo)" 0 #f #f) +(test-text-balanced? 2 "foo)" 0 #f #t) (test-text-balanced? 3 "(foo" 0 #f #f) (test-text-balanced? 4 "(foo)" 0 #f #t) -(test-text-balanced? 5 "(foo 'bar))" 0 #f #f) +(test-text-balanced? 5 "(foo 'bar))" 0 #f #t) (test-text-balanced? 6 "(foo) bar ([buz])" 0 #f #t) -(test-text-balanced? 7 "(foo]" 0 #f #f) +(test-text-balanced? 7 "(foo]" 0 #f #t) (test-text-balanced? 8 "{foo} ((bar) [5.9])" 0 #f #t) +(test-text-balanced? 9 "#(1 2 . 3)" 0 #f #t) From 412023deaf34b86e1586d6c1743e78f5bc466c18 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Aug 2010 11:22:47 -0400 Subject: [PATCH 015/462] avoid relying on bash original commit: da083f05e8f6a50156957f60fdca769c16607f26 --- collects/tests/framework/framework-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/framework/framework-test b/collects/tests/framework/framework-test index 645de72e..d7a8b640 100755 --- a/collects/tests/framework/framework-test +++ b/collects/tests/framework/framework-test @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/sh # {{{ here # Make this PATH-independent From 82eee9263f1aab31b2cf70a939533ae25e050014 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Aug 2010 23:55:56 -0400 Subject: [PATCH 016/462] reformat text original commit: f5ac79262556fb24e727ed71d2f199147c2c0151 --- collects/framework/main.rkt | 1539 +++++++++++++++++------------------ 1 file changed, 754 insertions(+), 785 deletions(-) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c4e3fe8b..c504b51a 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -54,143 +54,144 @@ (link standard-mred@ framework@)) (provide/doc - - (proc-doc/names + + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @scheme[arg] is an instance of the @tt{range} struct.}) - + (proc-doc/names text:range-start (-> text:range? exact-nonnegative-integer?) (range) @{Returns the start position of the range.}) + (proc-doc/names text:range-end (-> text:range? exact-nonnegative-integer?) (range) @{Returns the end position of the range.}) + (proc-doc/names text:range-caret-space? (-> text:range? boolean?) (range) - @{Returns a boolean indicating where the caret-space in the range goes. See also @method[text:basic<%> highlight-range].}) + @{Returns a boolean indicating where the caret-space in the range goes. + See also @method[text:basic<%> highlight-range].}) + (proc-doc/names text:range-style (-> text:range? exact-nonnegative-integer?) (range) - @{Returns the style of the range. See also @method[text:basic<%> highlight-range].}) + @{Returns the style of the range. + See also @method[text:basic<%> highlight-range].}) + (proc-doc/names text:range-color (-> text:range? (or/c string? (is-a?/c color%))) (range) @{Returns the color of the highlighted range.}) - + (parameter-doc text:autocomplete-append-after (parameter/c string?) suffix @{A string that is inserted after a completion is inserted by a - @scheme[text:autocomplete] instance. - - Defaults to @scheme[""].}) - + @scheme[text:autocomplete] instance. + + Defaults to @scheme[""].}) + (parameter-doc text:autocomplete-limit (parameter/c (and/c integer? exact? positive?)) count - @{Controls the number of completions visible at a time in the menu - produced by @scheme[text:autocomplete] instances. - - Defaults to 15.}) - + @{Controls the number of completions visible at a time in the menu produced + by @scheme[text:autocomplete] instances. + + Defaults to 15.}) + (proc-doc/names text:get-completions/manuals (-> (or/c false/c (listof symbol?)) (listof string?)) (manuals) - @{Returns the list of keywords for the manuals from @scheme[manuals] - by extracting all of the documented exports of the manuals. The - symbols are meant to be module paths, eg the quoted - form of the argument to @scheme[require]. + @{Returns the list of keywords for the manuals from @scheme[manuals] by + extracting all of the documented exports of the manuals. The symbols are + meant to be module paths, eg the quoted form of the argument to + @scheme[require]. + + If @scheme[manuals] is false, then all of the documented names are used.}) - If @scheme[manuals] is false, - then all of the documented names are used.}) - (proc-doc/names text:lookup-port-name (-> symbol? (or/c (is-a?/c editor:basic<%>) false/c)) (manuals) - @{Returns the editor instance whose port-name matches the given symbol. If no - editor can be found, then returns @scheme[false].}) - + @{Returns the editor instance whose port-name matches the given symbol. + If no editor can be found, then returns @scheme[false].}) + (proc-doc/names number-snip:make-repeating-decimal-snip (number? boolean? . -> . (is-a?/c snip%)) (num show-prefix?) - @{Makes a number snip that shows the decimal expansion for - @scheme[number] The boolean indicates if a @litchar{#e} prefix - appears on the number. - - See also @scheme[number-snip:make-fraction-snip].}) - + @{Makes a number snip that shows the decimal expansion for @scheme[number] + The boolean indicates if a @litchar{#e} prefix appears on the number. + + See also @scheme[number-snip:make-fraction-snip].}) + (proc-doc/names number-snip:make-fraction-snip (number? boolean? . -> . (is-a?/c snip%)) (num show-prefix-in-decimal-view?) @{Makes a number snip that shows a fractional view of @scheme[number]. - The boolean indicates if a @litchar{#e} prefix appears on the - number, when shown in the decimal state. - - See also @scheme[number-snip:make-repeating-decimal-snip].}) - + The boolean indicates if a @litchar{#e} prefix appears on the number, when + shown in the decimal state. + + See also @scheme[number-snip:make-repeating-decimal-snip].}) + (proc-doc/names version:add-spec (any/c any/c . -> . void?) (spec revision) - @{These two values are appended to the version string. @scheme[write] - is used to transform them to strings. For example: - - @scheme[(version:add-spec 's 1)] - - in version 205 will make the version string be @litchar{205s1}. The - symbols @scheme['f] and @scheme['d] are used internally for - framework and drscheme revisions.}) - + @{These two values are appended to the version string. @scheme[write] is + used to transform them to strings. For example: + + @scheme[(version:add-spec 's 1)] + + in version 205 will make the version string be @litchar{205s1}. The + symbols @scheme['f] and @scheme['d] are used internally for framework and + drscheme revisions.}) + (proc-doc/names version:version (-> string?) () - @{This function returns a string describing the version of this - application. See also @scheme[version:add-spec].}) - + @{This function returns a string describing the version of this application. + See also @scheme[version:add-spec].}) + (parameter-doc application:current-app-name (parameter/c string?) name - @{This is a parameter specifying the name of the current - application. It is used in the help menu - (see @scheme[frame:standard-menus%]) and in frame titles - (see @scheme[frame:editor%]). - The first case in the case-lambda returns the current name, and the - second case in the case-lambda sets the name of the application to - @scheme[name].}) - + @{This is a parameter specifying the name of the current application. It is + used in the help menu (see @scheme[frame:standard-menus%]) and in frame + titles (see @scheme[frame:editor%]). The first case in the case-lambda + returns the current name, and the second case in the case-lambda sets the + name of the application to @scheme[name].}) + (proc-doc/names preferences:put-preferences/gui (-> (listof symbol?) (listof any/c) any) (name-list val-list) - @{Like @scheme[put-preferences], but has more sophisticated error - handling. In particular, it - @itemize[ - @item{waits for three consecutive failures before informing the - user} - @item{gives the user the opportunity to ``steal'' the lockfile - after the third failure, and} - @item{when failures occur, it remembers what its arguments were - and if any preference save eventually succeeds, all of the - past failures are also written at that point.}]}) - + @{Like @scheme[put-preferences], but has more sophisticated error handling. + In particular, it + @itemize[ + @item{waits for three consecutive failures before informing the user} + @item{gives the user the opportunity to ``steal'' the lockfile after the + third failure, and} + @item{when failures occur, it remembers what its arguments were and if + any preference save eventually succeeds, all of the past failures + are also written at that point.}]}) + (proc-doc/names preferences:add-panel (-> (or/c string? (cons/c string? (listof string?))) @@ -205,118 +206,113 @@ (send parent get-children)))))]) void?) (labels f) - @{@scheme[preferences:add-preference-panel] adds the result of - @scheme[f] with name @scheme[labels] to the preferences dialog box. - - The labels determine where this preference panel is placed in the - dialog. If the list is just one string, the preferences panel is - placed at the top level of the dialog. If there are more strings, a - hierarchy of nested panels is created and the new panel is added at - the end. If multiple calls to - @scheme[preferences:add-preference-panel] pass the same prefix of - strings, those panels are placed in the same children. - - When the preference dialog is opened for the first time, the - function @scheme[f] is called with a panel, and @scheme[f] is - expected to add a new child panel to it and add whatever preferences - configuration controls it wants to that panel. Then, @scheme[f]'s - should return the panel it added.}) - + @{@scheme[preferences:add-preference-panel] adds the result of @scheme[f] + with name @scheme[labels] to the preferences dialog box. + + The labels determine where this preference panel is placed in the dialog. + If the list is just one string, the preferences panel is placed at the top + level of the dialog. If there are more strings, a hierarchy of nested + panels is created and the new panel is added at the end. If multiple calls + to @scheme[preferences:add-preference-panel] pass the same prefix of + strings, those panels are placed in the same children. + + When the preference dialog is opened for the first time, the function + @scheme[f] is called with a panel, and @scheme[f] is expected to add a new + child panel to it and add whatever preferences configuration controls it + wants to that panel. Then, @scheme[f]'s should return the panel it added.}) + (proc-doc/names preferences:add-editor-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options related to - editing.}) - + @{Adds a preferences panel for configuring options related to editing.}) + (proc-doc/names preferences:add-general-checkbox-panel (-> void?) () @{Adds a catch-all preferences panel for options.}) - + (proc-doc/names preferences:add-warnings-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options relating to - warnings.}) - + @{Adds a preferences panel for configuring options relating to warnings.}) + (proc-doc/names preferences:add-scheme-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options related to - Racket.}) - + @{Adds a preferences panel for configuring options related to Racket.}) + (proc-doc/names preferences:add-to-warnings-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Misc. panel to add new children to the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the Misc. panel to add new children to the panel.}) + (proc-doc/names preferences:add-to-scheme-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Racket preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the Racket preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-to-editor-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the editor preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the editor preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-to-general-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the general preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the general preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-font-panel (-> void?) () @{Adds a font selection preferences panel to the preferences dialog.}) - + (proc-doc/names preferences:show-dialog (-> void?) () @{Shows the preferences dialog.}) - + (proc-doc/names preferences:hide-dialog (-> void?) () @{Hides the preferences dialog.}) - + (proc-doc/names preferences:add-on-close-dialog-callback ((-> void?) . -> . void?) (cb) @{Registers @scheme[cb]. Next time the user clicks the OK button the - preferences dialog, all of the @scheme[cb] functions are called, - assuming that each of the callbacks passed to - @scheme[preferences:add-can-close-dialog-callback] succeed.}) - + preferences dialog, all of the @scheme[cb] functions are called, assuming + that each of the callbacks passed to + @scheme[preferences:add-can-close-dialog-callback] succeed.}) + (proc-doc/names preferences:add-can-close-dialog-callback ((-> boolean?) . -> . void?) (cb) @{Registers @scheme[cb]. Next time the user clicks the OK button the - preferences dialog, all of the @scheme[cb] functions are called. If - any of them return @scheme[#f], the dialog is not closed. - - See also @scheme[preferences:add-on-close-dialog-callback].}) - + preferences dialog, all of the @scheme[cb] functions are called. If any of + them return @scheme[#f], the dialog is not closed. + + See also @scheme[preferences:add-on-close-dialog-callback].}) + (proc-doc/names autosave:register ((and/c (is-a?/c autosave:autosavable<%>) @@ -324,138 +320,136 @@ . -> . void?) (obj) - @{Adds @scheme[obj] to the list of objects to be autosaved. When it - is time to autosave, the @scheme[do-autosave] method of the object - is called. This method is responsible for performing the autosave. - - There is no need to de-register an object because the autosaver - keeps a ``weak'' pointer to the object; i.e., the autosaver does not - keep an object from garbage collection.}) - + @{Adds @scheme[obj] to the list of objects to be autosaved. When it is time + to autosave, the @scheme[do-autosave] method of the object is called. This + method is responsible for performing the autosave. + + There is no need to de-register an object because the autosaver keeps a + ``weak'' pointer to the object; i.e., the autosaver does not keep an object + from garbage collection.}) + (proc-doc/names autosave:restore-autosave-files/gui (-> void?) () - @{Opens a GUI to ask the user about recovering any autosave files left - around from crashes and things. - - This function doesn't return until the user has finished restoring - the autosave files. (It uses yield to handle events however.)}) - + @{Opens a GUI to ask the user about recovering any autosave files left around + from crashes and things. + + This function doesn't return until the user has finished restoring the + autosave files. (It uses yield to handle events however.)}) + (proc-doc/names exit:exiting? (-> boolean?) () - @{Returns @scheme[#t] to indicate that an exit operation is taking - place. Does not indicate that the app will actually exit, since the - user may cancel the exit. - - See also @scheme[exit:insert-on-callback] and - @scheme[exit:insert-can?-callback].}) - + @{Returns @scheme[#t] to indicate that an exit operation is taking place. + Does not indicate that the app will actually exit, since the user may + cancel the exit. + + See also @scheme[exit:insert-on-callback] and + @scheme[exit:insert-can?-callback].}) + (proc-doc/names exit:set-exiting (boolean? . -> . void?) (exiting?) @{Sets a flag that affects the result of @scheme[exit:exiting?].}) - + (proc-doc/names exit:insert-on-callback ((-> void?) . -> . (-> void?)) (callback) - @{Adds a callback to be called when exiting. This callback must not - fail. If a callback should stop an exit from happening, use - @scheme[exit:insert-can?-callback].}) - + @{Adds a callback to be called when exiting. This callback must not fail. + If a callback should stop an exit from happening, use + @scheme[exit:insert-can?-callback].}) + (proc-doc/names exit:insert-can?-callback ((-> boolean?) . -> . (-> void?)) (callback) - @{Use this function to add a callback that determines if an attempted - exit can proceed. This callback should not clean up any state, - since another callback may veto the exit. Use - @scheme[exit:insert-on-callback] for callbacks that clean up - state.}) - + @{Use this function to add a callback that determines if an attempted exit + can proceed. This callback should not clean up any state, since another + callback may veto the exit. Use @scheme[exit:insert-on-callback] for + callbacks that clean up state.}) + (proc-doc/names exit:can-exit? (-> boolean?) () @{Calls the ``can-callbacks'' and returns their results. See - @scheme[exit:insert-can?-callback] for more information.}) - + @scheme[exit:insert-can?-callback] for more information.}) + (proc-doc/names exit:on-exit (-> void?) () - @{Calls the ``on-callbacks''. See @scheme[exit:insert-on-callback] - for more information.}) - + @{Calls the ``on-callbacks''. See @scheme[exit:insert-on-callback] for more + information.}) + (proc-doc/names exit:exit (-> any) () @{@scheme[exit:exit] performs four actions: - @itemize[ - @item{sets the result of the @scheme[exit:exiting?] function to - @scheme[#t].} - @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if - none of the ``can?'' callbacks return @scheme[#f],} - @item{invokes @scheme[exit:on-exit] and then} - @item{queues a callback that calls @scheme[exit] - (a mzscheme procedure) and (if @scheme[exit] returns) sets the result of - @scheme[exit:exiting?] back to @scheme[#t].}]}) - + @itemize[ + @item{sets the result of the @scheme[exit:exiting?] function to + @scheme[#t].} + @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if none of + the ``can?'' callbacks return @scheme[#f],} + @item{invokes @scheme[exit:on-exit] and then} + @item{queues a callback that calls @scheme[exit] (a mzscheme procedure) + and (if @scheme[exit] returns) sets the result of + @scheme[exit:exiting?] back to @scheme[#t].}]}) + (proc-doc/names exit:user-oks-exit (-> boolean?) () - @{Opens a dialog that queries the user about exiting. Returns the - user's decision.}) - + @{Opens a dialog that queries the user about exiting. Returns the user's + decision.}) + (proc-doc/names path-utils:generate-autosave-name (string? . -> . string?) (filename) @{Generates a name for an autosave file from @scheme[filename].}) - + (proc-doc/names path-utils:generate-backup-name (path? . -> . path?) (filename) @{Generates a name for an backup file from @scheme[filename].}) - + (parameter-doc finder:dialog-parent-parameter (parameter/c (or/c false/c (is-a?/c dialog%) (is-a?/c frame%))) parent @{This parameter determines the parent of the dialogs created by - @scheme[finder:get-file], @scheme[finder:put-file], - @scheme[finder:common-get-file], @scheme[finder:common-put-file], - @scheme[finder:common-get-file-list], @scheme[finder:std-get-file], - and @scheme[finder:std-put-file].}) - + @scheme[finder:get-file], @scheme[finder:put-file], + @scheme[finder:common-get-file], @scheme[finder:common-put-file], + @scheme[finder:common-get-file-list], @scheme[finder:std-get-file], + and @scheme[finder:std-put-file].}) + (parameter-doc finder:default-extension (parameter/c string?) extension @{This parameter controls the default extension for the framework's - @scheme[finder:put-file] dialog. Its value gets passed as the - @scheme[default-extension] argument to @scheme[put-file]. - - Its default value is @scheme[""].}) - + @scheme[finder:put-file] dialog. Its value gets passed as the + @scheme[default-extension] argument to @scheme[put-file]. + + Its default value is @scheme[""].}) + (parameter-doc finder:default-filters (parameter/c (listof (list/c string? string?))) filters - @{ - This parameter controls the default filters for the framework's - @scheme[finder:put-file] dialog. Its value gets passed as the - @scheme[default-filters] argument to @scheme[put-file]. - - Its default value is @scheme['(("Any" "*.*"))].}) - + @{This parameter controls the default filters for the framework's + @scheme[finder:put-file] dialog. Its value gets passed as the + @scheme[default-filters] argument to @scheme[put-file]. + + Its default value is @scheme['(("Any" "*.*"))].}) + (proc-doc/names finder:common-put-file (->* () @@ -476,9 +470,9 @@ (filter-msg "That filename does not have the right form.") (parent (finder:dialog-parent-parameter)))) @{This procedure queries the user for a single filename, using a - platform-independent dialog box. Consider using - @scheme[finder:put-file] instead of this function.}) - + platform-independent dialog box. Consider using @scheme[finder:put-file] + instead of this function.}) + (proc-doc/names finder:common-get-file (->* () @@ -495,9 +489,9 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{This procedure queries the user for a single filename, using a - platform-independent dialog box. Consider using - @scheme[finder:get-file] instead of this function.}) - + platform-independent dialog box. Consider using + @scheme[finder:get-file] instead of this function.}) + (proc-doc/names finder:std-put-file (->* () @@ -518,9 +512,9 @@ (filter-msg "That filename does not have the right form.") (parent (finder:dialog-parent-parameter)))) @{This procedure queries the user for a single filename, using a - platform-dependent dialog box. Consider using - @scheme[finder:put-file] instead of this function.}) - + platform-dependent dialog box. Consider using @scheme[finder:put-file] + instead of this function.}) + (proc-doc/names finder:std-get-file (->* () @@ -537,9 +531,9 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{This procedure queries the user for a single filename, using a - platform-dependent dialog box. Consider using - @scheme[finder:get-file] instead of this function.}) - + platform-dependent dialog box. Consider using @scheme[finder:get-file] + instead of this function.}) + (proc-doc/names finder:put-file (->* () @@ -560,11 +554,11 @@ (filter-msg "That filename does not have the right form.") (parent (finder:dialog-parent-parameter)))) @{Queries the user for a filename. - - If the result of @scheme[(preferences:get 'framework:file-dialogs)] - is @scheme['std] this calls @scheme[finder:std-put-file], and if it - is @scheme['common], @scheme[finder:common-put-file] is called.}) - + + If the result of @scheme[(preferences:get 'framework:file-dialogs)] is + @scheme['std] this calls @scheme[finder:std-put-file], and if it is + @scheme['common], @scheme[finder:common-put-file] is called.}) + (proc-doc/names finder:get-file (->* () @@ -581,11 +575,11 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{Queries the user for a filename. - - If the result of @scheme[(preferences:get 'framework:file-dialogs)] - is @scheme['std] this calls @scheme[finder:std-get-file], and if it - is @scheme['common], @scheme[finder:common-get-file] is called.}) - + + If the result of @scheme[(preferences:get 'framework:file-dialogs)] is + @scheme['std] this calls @scheme[finder:std-get-file], and if it is + @scheme['common], @scheme[finder:common-get-file] is called.}) + (proc-doc/names finder:common-get-file-list (->* () @@ -602,17 +596,17 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{This procedure queries the user for a list of filenames, using a - platform-independent dialog box.}) - + platform-independent dialog box.}) + (proc-doc/names frame:setup-size-pref (symbol? number? number? . -> . void) (size-pref-sym width height) @{Initializes a preference for the @scheme[frame:size-pref] mixin. - - The first argument should be the preferences symbol, and the second - an third should be the default width and height, respectively.}) - + + The first argument should be the preferences symbol, and the second an + third should be the default width and height, respectively.}) + (proc-doc/names frame:add-snip-menu-items (->* ((is-a?/c menu%) (subclass?/c menu-item%)) @@ -620,31 +614,31 @@ void?) ((menu menu-item%) ((func void))) - @{Inserts three menu items into @scheme[menu], one that inserts a text - box, one that inserts a pasteboard box, and one that inserts an - image into the currently focused editor (if there is one). Uses - @scheme[menu-item%] as the class for the menu items. - - Calls @scheme[func] right after inserting each menu item.}) - + @{Inserts three menu items into @scheme[menu], one that inserts a text box, + one that inserts a pasteboard box, and one that inserts an image into the + currently focused editor (if there is one). Uses @scheme[menu-item%] as + the class for the menu items. + + Calls @scheme[func] right after inserting each menu item.}) + (proc-doc/names frame:reorder-menus ((is-a?/c frame%) . -> . void?) (frame) - @{Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' - menus to the front of the menubar and moves the ``Windows'' and - ``Help'' menus to the end of the menubar. - - This is useful in conjunction with the frame classes. After - instantiating the class and adding ones own menus, the menus will be - mis-ordered. This function fixes them up.}) - + @{Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' menus + to the front of the menubar and moves the ``Windows'' and ``Help'' menus to + the end of the menubar. + + This is useful in conjunction with the frame classes. After instantiating + the class and adding ones own menus, the menus will be mis-ordered. This + function fixes them up.}) + (proc-doc/names frame:remove-empty-menus ((is-a?/c frame%) . -> . void?) (frame) @{Removes empty menus in a frame.}) - + (parameter-doc frame:current-icon (parameter/c (or/c #f @@ -654,77 +648,78 @@ icon-spec @{The value of this parameter is used by the initialization code of @scheme[frame:basic-mixin]. - @itemize[@item{If it is @scheme[#f], then its value is - ignored.} - @item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is called - with the bitmap, the result of invoking the @scheme[bitmap% get-loaded-mask] method, - and @scheme['both].} - @item{If it is a pair of bitmaps, then the @method[frame% set-icon] - method is invoked twice, once with each bitmap in the pair. The first bitmap - is passed (along with the result of its @scheme[bitmap% get-loaded-mask]) - and @scheme['small], and then the second bitmap is passed - (also along with the result of its @scheme[bitmap% get-loaded-mask]) and @scheme['large].}] + @itemize[ + @item{If it is @scheme[#f], then its value is ignored.} + @item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is + called with the bitmap, the result of invoking the + @scheme[bitmap% get-loaded-mask] method, and @scheme['both].} + @item{If it is a pair of bitmaps, then the @method[frame% set-icon] + method is invoked twice, once with each bitmap in the pair. The + first bitmap is passed (along with the result of its + @scheme[bitmap% get-loaded-mask]) and @scheme['small], and then the + second bitmap is passed (also along with the result of its + @scheme[bitmap% get-loaded-mask]) and @scheme['large].}] Defaults to @scheme[#f].}) - + (proc-doc/names group:get-the-frame-group (-> (is-a?/c group:%)) () @{This returns the frame group.}) - + (proc-doc/names group:on-close-action (-> void?) () @{See also @scheme[group:can-close-check]. - - Call this function from the @method[top-level-window<%> can-close?] - callback of a frame in order for the group to properly close the - application.}) - + + Call this function from the @method[top-level-window<%> can-close?] + callback of a frame in order for the group to properly close the + application.}) + (proc-doc/names group:can-close-check (-> boolean?) () @{See also @scheme[group:on-close-action]. - - Call this function from the @method[top-level-window<%> can-close?] - callback of a frame in order for the group to properly close the - application.}) - + + Call this function from the @method[top-level-window<%> can-close?] + callback of a frame in order for the group to properly close the + application.}) + (proc-doc/names group:add-to-windows-menu (-> (-> (is-a?/c menu%) any) any) (proc) - @{Procedures passed to this function are called when the @onscreen{Windows} menu is - created. Use it to add additional menu items.}) - + @{Procedures passed to this function are called when the @onscreen{Windows} + menu is created. Use it to add additional menu items.}) + (proc-doc/names handler:handler? (any/c . -> . boolean?) (obj) @{This predicate determines if its input is a handler.}) - + (proc-doc/names handler:handler-name (handler:handler? . -> . string?) (handler) @{Extracts the name from a handler.}) - + (proc-doc/names handler:handler-extension (handler:handler? . -> . (or/c (path? . -> . boolean?) (listof string?))) (handler) @{Extracts the extension from a handler.}) - + (proc-doc/names handler:handler-handler (handler:handler? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (handler) @{Extracs the handler's handling function.}) - + (proc-doc/names handler:insert-format-handler (string? @@ -734,37 +729,37 @@ void?) (name pred handler) @{This function inserts a format handler. - - The string, @scheme[name] names the format handler for use with - @scheme[handler:find-named-format-handler]. If @scheme[pred] is a - string, it is matched with the extension of a filename by - @scheme[handler:find-format-handler]. If @scheme[pred] is a list of - strings, they are each matched with the extension of a filename by - @scheme[handler:find-format-handler]. If it is a function, the - filename is applied to the function and the functions result - determines if this is the handler to use. - - The most recently added format handler takes precedence over all - other format handlers.}) - + + The string, @scheme[name] names the format handler for use with + @scheme[handler:find-named-format-handler]. If @scheme[pred] is a string, + it is matched with the extension of a filename by + @scheme[handler:find-format-handler]. If @scheme[pred] is a list of + strings, they are each matched with the extension of a filename by + @scheme[handler:find-format-handler]. If it is a function, the filename is + applied to the function and the functions result determines if this is the + handler to use. + + The most recently added format handler takes precedence over all other + format handlers.}) + (proc-doc/names handler:find-named-format-handler (string? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (name) @{This function selects a format handler. See also - @scheme[handler:insert-format-handler]. - - It finds a handler based on @scheme[name].}) - + @scheme[handler:insert-format-handler]. + + It finds a handler based on @scheme[name].}) + (proc-doc/names handler:find-format-handler (path? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (filename) @{This function selects a format handler. See also - @scheme[handler:insert-format-handler]. - - It finds a handler based on @scheme[filename].}) - + @scheme[handler:insert-format-handler]. + + It finds a handler based on @scheme[filename].}) + (proc-doc/names handler:edit-file (->* ((or/c path? false/c)) @@ -773,212 +768,206 @@ ((filename) ((make-default (λ () ((handler:current-create-new-window) filename))))) - @{This function creates a frame or re-uses an existing frame to edit a - file. - - If the preference @scheme['framework:open-here] is set to - @scheme[#t], and - @scheme[(send (group:get-the-frame-group) get-open-here-frame)] - returns a frame, the - @method[frame:open-here<%> open-here] method of that frame is used - to load the file in the existing frame. - - Otherwise, it invokes the appropriate format handler to open the - file (see @scheme[handler:insert-format-handler]). - - @itemize[ - @item{If @scheme[filename] is a string, this function checks the - result of @scheme[group:get-the-frame-group] to see if the - @scheme[filename] is already open by a frame in the group. - @itemize[ - @item{If so, it returns the frame.} - @item{If not, this function calls - @scheme[handler:find-format-handler] with - @scheme[filename]. - @itemize[ - @item{If a handler is found, it is applied to - @scheme[filename] and it's result is the - final result.} - @item{If not, @scheme[make-default] is used.}]}]} - @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] - is used.}]}) - + @{This function creates a frame or re-uses an existing frame to edit a file. + + If the preference @scheme['framework:open-here] is set to @scheme[#t], and + @scheme[(send (group:get-the-frame-group) get-open-here-frame)] returns a + frame, the @method[frame:open-here<%> open-here] method of that frame is + used to load the file in the existing frame. + + Otherwise, it invokes the appropriate format handler to open the file (see + @scheme[handler:insert-format-handler]). + + @itemize[ + @item{If @scheme[filename] is a string, this function checks the result + of @scheme[group:get-the-frame-group] to see if the + @scheme[filename] is already open by a frame in the group. + @itemize[ + @item{If so, it returns the frame.} + @item{If not, this function calls + @scheme[handler:find-format-handler] with + @scheme[filename]. + @itemize[ + @item{If a handler is found, it is applied to + @scheme[filename] and it's result is the final + result.} + @item{If not, @scheme[make-default] is used.}]}]} + @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] is + used.}]}) + (parameter-doc handler:current-create-new-window (parameter/c (-> (or/c false/c path?) (is-a?/c frame%))) proc - @{This is a parameter that controls how the framework creates new - application windows. - - The default setting is this: - @schemeblock[ - (λ (filename) - (let ([frame (make-object frame:text-info-file% filename)]) - (send frame show #t) - frame)) - ]}) - + @{This is a parameter that controls how the framework creates new application + windows. + + The default setting is this: + @schemeblock[(λ (filename) + (let ([frame (make-object frame:text-info-file% filename)]) + (send frame show #t) + frame))]}) + (proc-doc/names handler:open-file (->* () ((or/c false/c path? string?)) (or/c false/c (is-a?/c frame:basic<%>))) - (() + (() ((dir #f))) @{This function queries the user for a filename and opens the file for - editing. It uses @scheme[handler:edit-file] to open the file, once - the user has chosen it. - - Calls @scheme[finder:get-file] and @scheme[handler:edit-file], passing along @scheme[dir].}) - + editing. It uses @scheme[handler:edit-file] to open the file, once the + user has chosen it. + + Calls @scheme[finder:get-file] and @scheme[handler:edit-file], passing + along @scheme[dir].}) + (proc-doc/names handler:install-recent-items ((is-a?/c menu%) . -> . void?) (menu) - @{This function deletes all of the items in the given menu and adds - one menu item for each recently opened file. These menu items, when - selected, call @scheme[handler:edit-file] with the filename of the - recently opened file. - - The menu's size is limited to 10.}) - + @{This function deletes all of the items in the given menu and adds one menu + item for each recently opened file. These menu items, when selected, call + @scheme[handler:edit-file] with the filename of the recently opened file. + + The menu's size is limited to 10.}) + (proc-doc/names handler:set-recent-items-frame-superclass ((implementation?/c frame:standard-menus<%>) . -> . void?) (frame) @{Sets the superclass for the recently opened files frame. It must be - derived from @scheme[frame:standard-menus].}) - + derived from @scheme[frame:standard-menus].}) + (proc-doc/names handler:add-to-recent (path? . -> . void?) (filename) @{Adds a filename to the list of recently opened files.}) - + (proc-doc/names handler:set-recent-position (path? number? number? . -> . void?) (filename start end) @{Sets the selection of the recently opened file to @scheme[start] and - @scheme[end].}) - + @scheme[end].}) + (proc-doc/names handler:size-recently-opened-files (number? . -> . void?) (num) - @{Sizes the @scheme['framework:recently-opened-files/pos] preference - list length to @scheme[num].}) - + @{Sizes the @scheme['framework:recently-opened-files/pos] preference list + length to @scheme[num].}) + (proc-doc/names icon:get-paren-highlight-bitmap (-> (is-a?/c bitmap%)) () - @{This returns the parenthesis highlight @scheme[bitmap%]. It is only - used on black and white screens.}) - + @{This returns the parenthesis highlight @scheme[bitmap%]. It is only used + on black and white screens.}) + (proc-doc/names icon:get-eof-bitmap (-> (is-a?/c bitmap%)) () - @{This returns the @scheme[bitmap%] used for the clickable ``eof'' - icon from @scheme[text:ports].}) - + @{This returns the @scheme[bitmap%] used for the clickable ``eof'' icon from + @scheme[text:ports].}) + (proc-doc/names icon:get-autowrap-bitmap (-> (is-a?/c bitmap%)) () @{This returns the autowrap's @scheme[bitmap%]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-lock-bitmap (-> (is-a?/c bitmap%)) () @{This returns the lock's @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-unlock-bitmap (-> (is-a?/c bitmap%)) () @{This returns the reset unlocked @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-anchor-bitmap (-> (is-a?/c bitmap%)) () @{This returns the anchor's @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-left/right-cursor (-> (is-a?/c cursor%)) () - @{This function returns a @scheme[cursor%] object that indicates - left/right sizing is possible, for use with columns inside a window. - - The cursor may not respond @scheme[#t] to the @method[cursor% ok?] - method.}) - + @{This function returns a @scheme[cursor%] object that indicates left/right + sizing is possible, for use with columns inside a window. + + The cursor may not respond @scheme[#t] to the @method[cursor% ok?] + method.}) + (proc-doc/names icon:get-up/down-cursor (-> (is-a?/c cursor%)) () - @{This function returns a @scheme[cursor%] object that indicates - up/down sizing is possible, for use with columns inside a window. - - The cursor may not respond @scheme[#t] to the @method[cursor% ok?] - method.}) - + @{This function returns a @scheme[cursor%] object that indicates up/down + sizing is possible, for use with columns inside a window. + + The cursor may not respond @scheme[#t] to the @method[cursor% ok?] + method.}) + (proc-doc/names icon:get-gc-on-bitmap (-> (is-a?/c bitmap%)) () - @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] - frame when garbage collection is taking place. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] frame + when garbage collection is taking place. + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-gc-off-bitmap (-> (is-a?/c bitmap%)) () - @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] - frame when garbage collection is not taking place. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] frame + when garbage collection is not taking place. + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names keymap:remove-user-keybindings-file (-> any/c any) (user-keybindings-path) @{Removes the keymap previously added by - @scheme[keymap:add-user-keybindings-file].}) - + @scheme[keymap:add-user-keybindings-file].}) + (proc-doc/names keymap:add-user-keybindings-file (-> any/c any) (user-keybindings-path-or-require-spec) - @{Chains the keymap defined by - @scheme[user-keybindings-path-or-require-spec] to the global keymap, - returned by @scheme[keymap:get-global]. - - If @scheme[user-keybindings-path-or-require-spec] is a path, the - module is loaded directly from that path. Otherwise, - @scheme[user-keybindings-path-or-require-spec] is treated like an - argument to @scheme[require].}) - + @{Chains the keymap defined by @scheme[user-keybindings-path-or-require-spec] + to the global keymap, returned by @scheme[keymap:get-global]. + + If @scheme[user-keybindings-path-or-require-spec] is a path, the module is + loaded directly from that path. Otherwise, + @scheme[user-keybindings-path-or-require-spec] is treated like an argument + to @scheme[require].}) + (parameter-doc keymap:add-to-right-button-menu (parameter/c @@ -987,64 +976,63 @@ (is-a?/c event%) void?)) proc - @{When the keymap that @scheme[keymap:get-global] returns is installed - into an editor, this parameter's value is used for right button - clicks. - - Before calling this procedure, the function - @scheme[append-editor-operation-menu-items] is called. - - See also @scheme[keymap:add-to-right-button-menu/before].}) - + @{When the keymap that @scheme[keymap:get-global] returns is installed into + an editor, this parameter's value is used for right button clicks. + + Before calling this procedure, the function + @scheme[append-editor-operation-menu-items] is called. + + See also @scheme[keymap:add-to-right-button-menu/before].}) + (parameter-doc keymap:add-to-right-button-menu/before (parameter/c (-> (is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) void?)) proc - @{When the keymap that @scheme[keymap:get-global] returns is installed - into an editor, this function is called for right button clicks. - - After calling this procedure, the function - @scheme[append-editor-operation-menu-items] is called. - - See also @scheme[keymap:add-to-right-button-menu].}) - + @{When the keymap that @scheme[keymap:get-global] returns is installed into + an editor, this function is called for right button clicks. + + After calling this procedure, the function + @scheme[append-editor-operation-menu-items] is called. + + See also @scheme[keymap:add-to-right-button-menu].}) + (proc-doc/names keymap:call/text-keymap-initializer ((-> any/c) . -> . any/c) (thunk-proc) - @{Thus function parameterizes the call to @scheme[thunk-proc] by - setting the keymap-initialization procedure (see - @scheme[current-text-keymap-initializer]) to install the framework's - standard text bindings.}) - + @{Thus function parameterizes the call to @scheme[thunk-proc] by setting the + keymap-initialization procedure (see + @scheme[current-text-keymap-initializer]) to install the framework's + standard text bindings.}) + (proc-doc/names keymap:canonicalize-keybinding-string (string? . -> . string?) (keybinding-string) - @{Returns a string that denotes the same keybindings as the input - string, except that it is in canonical form; two canonical - keybinding strings can be compared with @scheme[string=?].}) - + @{Returns a string that denotes the same keybindings as the input string, + except that it is in canonical form; two canonical keybinding strings can + be compared with @scheme[string=?].}) + (proc-doc/names keymap:get-editor (-> (is-a?/c keymap%)) () - @{This returns a keymap for handling standard editing operations. It - binds these keys: - - @itemize[ - @item{@scheme["z"]: undo} - @item{@scheme["y"]: redo} - @item{@scheme["x"]: cut} - @item{@scheme["c"]: copy} - @item{@scheme["v"]: paste} - @item{@scheme["a"]: select all}] - where each key is prefixed with the menu-shortcut key, based on the - platform. Under unix, the shortcut is @scheme["a:"]; under windows - the shortcut key is @scheme["c:"] and under MacOS, the shortcut key - is @scheme["d:"].}) - + @{This returns a keymap for handling standard editing operations. It binds + these keys: + + @itemize[ + @item{@scheme["z"]: undo} + @item{@scheme["y"]: redo} + @item{@scheme["x"]: cut} + @item{@scheme["c"]: copy} + @item{@scheme["v"]: paste} + @item{@scheme["a"]: select all}] + where each key is prefixed with the menu-shortcut key, based on the + platform. Under unix, the shortcut is @scheme["a:"]; under windows the + shortcut key is @scheme["c:"] and under MacOS, the shortcut key is + @scheme["d:"].}) + (proc-doc/names keymap:get-file (-> (is-a?/c keymap%)) @@ -1055,239 +1043,229 @@ keymap:get-user (-> (is-a?/c keymap%)) () - @{This returns a keymap that contains all of the keybindings in the keymaps loaded via @scheme[keymap:add-user-keybindings-file]}) + @{This returns a keymap that contains all of the keybindings in the keymaps + loaded via @scheme[keymap:add-user-keybindings-file]}) - (proc-doc/names keymap:get-global (-> (is-a?/c keymap%)) () @{This returns a keymap for general operations. See - @scheme[keymap:setup-global] for a list of the bindings this keymap - contains.}) - + @scheme[keymap:setup-global] for a list of the bindings this keymap + contains.}) + (proc-doc/names keymap:get-search (-> (is-a?/c keymap%)) () @{This returns a keymap for searching operations.}) - + (proc-doc/names keymap:make-meta-prefix-list (string? . -> . (listof string?)) (key) - @{This prefixes a key with all of the different meta prefixes and - returns a list of the prefixed strings. - - takes a keymap, a base key specification, and a function name; it - prefixes the base key with all ``meta'' combination prefixes, and - installs the new combinations into the keymap. For example, - @scheme[(keymap:send-map-function-meta keymap "a" func)] maps - @scheme["m:a"] and @scheme["ESC;a"] to @scheme[func].}) - + @{This prefixes a key with all of the different meta prefixes and returns a + list of the prefixed strings. + + takes a keymap, a base key specification, and a function name; it prefixes + the base key with all ``meta'' combination prefixes, and installs the new + combinations into the keymap. For example, + @scheme[(keymap:send-map-function-meta keymap "a" func)] maps + @scheme["m:a"] and @scheme["ESC;a"] to @scheme[func].}) + (proc-doc/names keymap:send-map-function-meta ((is-a?/c keymap%) string? string? . -> . void?) (keymap key func) - @{@index{Meta} Most keyboard and mouse mappings are inserted into a - keymap by calling the keymap's @method[keymap% map-function] method. - However, ``meta'' combinations require special attention. The - @scheme["m:"] prefix recognized by @method[keymap% map-function] - applies only to the Meta key that exists on some keyboards. By - convention, however, ``meta'' combinations can also be accessed by - using ``ESC'' as a prefix. - - This procedure binds all of the key-bindings obtained by prefixing - @scheme[key] with a meta-prefix to @scheme[func] in - @scheme[keymap].}) - + @{@index{Meta} Most keyboard and mouse mappings are inserted into a keymap by + calling the keymap's @method[keymap% map-function] method. However, + ``meta'' combinations require special attention. The @scheme["m:"] prefix + recognized by @method[keymap% map-function] applies only to the Meta key + that exists on some keyboards. By convention, however, ``meta'' + combinations can also be accessed by using ``ESC'' as a prefix. + + This procedure binds all of the key-bindings obtained by prefixing + @scheme[key] with a meta-prefix to @scheme[func] in @scheme[keymap].}) + (proc-doc/names keymap:setup-editor ((is-a?/c keymap%) . -> . void?) (keymap) @{This sets up the input keymap with the bindings described in - @scheme[keymap:get-editor].}) - + @scheme[keymap:get-editor].}) + (proc-doc/names keymap:setup-file ((is-a?/c keymap%) . -> . void?) (keymap) @{This extends a @scheme[keymap%] with the bindings for files.}) - + (proc-doc/names keymap:setup-global ((is-a?/c keymap%) . -> . void?) (keymap) @{This extends a @scheme[keymap%] with the general bindings. - - This function extends a @scheme[keymap%] with the following - functions: - @itemize[ - @item{@mapdesc[ring-bell any] --- Rings the bell - (using @scheme[bell]) and removes the search panel from the frame, - if there.} - @item{@mapdesc[save-file key] --- Saves the buffer. If the buffer - has no name, then - @scheme[finder:put-file]@index["finder:put-file"] is - invoked.} - @item{@mapdesc[save-file-as key] --- Calls - @scheme[finder:put-file]@index["finder:put-file"] to save - the buffer.} - @item{@mapdesc[load-file key] --- Invokes - @scheme[finder:open-file]@index["finder:open-file"].} - @item{@mapdesc[find-string key] --- Opens the search buffer at the - bottom of the frame, unless it is already open, in which - case it searches for the text in the search buffer.} - @item{@mapdesc[find-string-reverse key] --- Same as - ``find-string'', but in the reverse direction.} - @item{@mapdesc[find-string-replace key] --- Opens a replace string - dialog box.} - @item{@mapdesc[toggle-anchor key] --- Turns selection-anchoring on - or off.} - @item{@mapdesc[center-view-on-line key] --- Centers the buffer in - its display using the currently selected line.} - @item{@mapdesc[collapse-space key] --- Collapses all non-return - whitespace around the caret into a single space.} - @item{@mapdesc[remove-space key] --- Removes all non-return - whitespace around the caret.} - @item{@mapdesc[collapse-newline key] --- Collapses all empty lines - around the caret into a single empty line. If there is only - one empty line, it is removed.} - @item{@mapdesc[open-line key] --- Inserts a new line.} - @item{@mapdesc[transpose-chars key] --- Transposes the characters - before and after the caret and moves forward one position.} - @item{@mapdesc[transpose-words key] --- Transposes words before - and after the caret and moves forward one word.} - @item{@mapdesc[capitalize-word key] --- Changes the first - character of the next word to a capital letter and moves to - the end of the word.} - @item{@mapdesc[upcase-word key] --- Changes all characters of the - next word to capital letters and moves to the end of the - word.} - @item{@mapdesc[downcase-word key] --- Changes all characters - of the next word to lowercase letters and moves to the end - of the word.} - @item{@mapdesc[kill-word key] --- Kills the next word.} - @item{@mapdesc[backward-kill-word key] --- Kills the previous - word.} - @item{@mapdesc[goto-line any] --- Queries the user for a line - number and moves the caret there.} - @item{@mapdesc[goto-position any] --- Queries the user for a - position number and moves the caret there.} - @item{@mapdesc[copy-clipboard mouse] --- Copies the current - selection to the clipboard.} - @item{@mapdesc[cut-clipboard mouse] --- Cuts the current selection - to the clipboard.} - @item{@mapdesc[paste-clipboard mouse] --- Patses the clipboard to - the current selection.} - @item{@mapdesc[copy-click-region mouse] --- Copies the region - between the caret and the input mouse event.} - @item{@mapdesc[cut-click-region mouse] --- Cuts the region - between the caret and the input mouse event.} - @item{@mapdesc[paste-click-region mouse] --- Pastes the clipboard - into the position of the input mouse event.} - @item{@mapdesc[select-click-word mouse] --- Selects the word under - the input mouse event.} - @item{@mapdesc[select-click-line mouse] --- Selects the line under - the input mouse event.} - @item{@mapdesc[start-macro key] -- Starts building a keyboard - macro} - @item{@mapdesc[end-macro key] --- Stops building a keyboard macro} - @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} - @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting - mode}] - - These functions are bound to the following keys - (C = control, S = shift, A = alt, M = ``meta'', D = command): - - @itemize[ - @item{C-g : ``ring-bell''} - @item{M-C-g : ``ring-bell''} - @item{C-c C-g : ``ring-bell''} - @item{C-x C-g : ``ring-bell''} - @item{C-p : ``previous-line''} - @item{S-C-p : ``select-previous-line''} - @item{C-n : ``next-line''} - @item{S-C-n : ``select-next-line''} - @item{C-e : ``end-of-line''} - @item{S-C-e : ``select-to-end-of-line''} - @item{D-RIGHT : ``end-of-line''} - @item{S-D-RIGHT : ``select-to-end-of-line''} - @item{M-RIGHT : ``end-of-line''} - @item{S-M-RIGHT : ``select-to-end-of-line''} - @item{C-a : ``beginning-of-line''} - @item{S-C-a : ``select-to-beginning-of-line''} - @item{D-LEFT : ``beginning-of-line''} - @item{D-S-LEFT : ``select-to-beginning-of-line''} - @item{M-LEFT : ``beginning-of-line''} - @item{M-S-LEFT : ``select-to-beginning-of-line''} - @item{C-h : ``delete-previous-character''} - @item{C-d : ``delete-next-character''} - @item{C-f : ``forward-character''} - @item{S-C-f : ``select-forward-character''} - @item{C-b : ``backward-character''} - @item{S-C-b : ``select-backward-character''} - @item{M-f : ``forward-word''} - @item{S-M-f : ``select-forward-word''} - @item{A-RIGHT : ``forward-word''} - @item{A-S-RIGHT : ``forward-select-word''} - @item{M-b : ``backward-word''} - @item{S-M-b : ``select-backward-word''} - @item{A-LEFT : ``backward-word''} - @item{A-S-LEFT : ``backward-select-word''} - @item{M-d : ``kill-word''} - @item{M-DELETE : ``backward-kill-word''} - @item{M-c : ``capitalize-word''} - @item{M-u : ``upcase-word''} - @item{M-l : ``downcase-word''} - @item{M-< : ``beginning-of-file''} - @item{S-M-< : ``select-to-beginning-of-file''} - @item{M-> : ``end-of-file''} - @item{S-M-> : ``select-to-end-of-file''} - @item{C-v : ``next-page''} - @item{S-C-v : ``select-next-page''} - @item{M-v : ``previous-page''} - @item{S-M-v : ``select-previous-page''} - @item{C-l : ``center-view-on-line''} - @item{C-k : ``delete-to-end-of-line''} - @item{C-y : ``paste-clipboard'' (Except Windows)} - @item{A-v : ``paste-clipboard''} - @item{D-v : ``paste-clipboard''} - @item{C-_ : ``undo''} - @item{C-x u : ``undo''} - @item{C-+ : ``redo''} - @item{C-w : ``cut-clipboard''} - @item{M-w : ``copy-clipboard''} - @item{C-x C-s : ``save-file''} - @item{C-x C-w : ``save-file-as''} - @item{C-x C-f : ``load-file''} - @item{C-s : ``find-string''} - @item{C-r : ``find-string-reverse''} - @item{M-% : ``find-string-replace''} - @item{SPACE : ``collapse-space''} - @item{M-Backslash : ``remove-space''} - @item{C-x C-o : ``collapse-newline''} - @item{C-o : ``open-line''} - @item{C-t : ``transpose-chars''} - @item{M-t : ``transpose-words''} - @item{C-SPACE : ``toggle-anchor''} - @item{M-g : ``goto-line''} - @item{M-p : ``goto-position''} - @item{LEFTBUTTONTRIPLE : ``select-click-line''} - @item{LEFTBUTTONDOUBLE : ``select-click-word''} - @item{RIGHTBUTTON : ``copy-click-region''} - @item{RIGHTBUTTONDOUBLE : ``cut-click-region''} - @item{MIDDLEBUTTON : ``paste-click-region''} - @item{C-RIGHTBUTTON : ``copy-clipboard''} - @item{INSERT : ``toggle-overwrite''} - @item{M-o : ``toggle-overwrite''}]}) - + + This function extends a @scheme[keymap%] with the following functions: + @itemize[ + @item{@mapdesc[ring-bell any] --- Rings the bell (using @scheme[bell]) + and removes the search panel from the frame, if there.} + @item{@mapdesc[save-file key] --- Saves the buffer. If the buffer has no + name, then @scheme[finder:put-file]@index["finder:put-file"] is + invoked.} + @item{@mapdesc[save-file-as key] --- Calls + @scheme[finder:put-file]@index["finder:put-file"] to save the + buffer.} + @item{@mapdesc[load-file key] --- Invokes + @scheme[finder:open-file]@index["finder:open-file"].} + @item{@mapdesc[find-string key] --- Opens the search buffer at the bottom + of the frame, unless it is already open, in which case it searches + for the text in the search buffer.} + @item{@mapdesc[find-string-reverse key] --- Same as ``find-string'', but + in the reverse direction.} + @item{@mapdesc[find-string-replace key] --- Opens a replace string dialog + box.} + @item{@mapdesc[toggle-anchor key] --- Turns selection-anchoring on or + off.} + @item{@mapdesc[center-view-on-line key] --- Centers the buffer in its + display using the currently selected line.} + @item{@mapdesc[collapse-space key] --- Collapses all non-return + whitespace around the caret into a single space.} + @item{@mapdesc[remove-space key] --- Removes all non-return whitespace + around the caret.} + @item{@mapdesc[collapse-newline key] --- Collapses all empty lines around + the caret into a single empty line. If there is only one empty + line, it is removed.} + @item{@mapdesc[open-line key] --- Inserts a new line.} + @item{@mapdesc[transpose-chars key] --- Transposes the characters before + and after the caret and moves forward one position.} + @item{@mapdesc[transpose-words key] --- Transposes words before and after + the caret and moves forward one word.} + @item{@mapdesc[capitalize-word key] --- Changes the first character of + the next word to a capital letter and moves to the end of the + word.} + @item{@mapdesc[upcase-word key] --- Changes all characters of the next + word to capital letters and moves to the end of the word.} + @item{@mapdesc[downcase-word key] --- Changes all characters of the next + word to lowercase letters and moves to the end of the word.} + @item{@mapdesc[kill-word key] --- Kills the next word.} + @item{@mapdesc[backward-kill-word key] --- Kills the previous word.} + @item{@mapdesc[goto-line any] --- Queries the user for a line number and + moves the caret there.} + @item{@mapdesc[goto-position any] --- Queries the user for a position + number and moves the caret there.} + @item{@mapdesc[copy-clipboard mouse] --- Copies the current selection to + the clipboard.} + @item{@mapdesc[cut-clipboard mouse] --- Cuts the current selection to the + clipboard.} + @item{@mapdesc[paste-clipboard mouse] --- Patses the clipboard to the + current selection.} + @item{@mapdesc[copy-click-region mouse] --- Copies the region between the + caret and the input mouse event.} + @item{@mapdesc[cut-click-region mouse] --- Cuts the region between the + caret and the input mouse event.} + @item{@mapdesc[paste-click-region mouse] --- Pastes the clipboard into + the position of the input mouse event.} + @item{@mapdesc[select-click-word mouse] --- Selects the word under the + input mouse event.} + @item{@mapdesc[select-click-line mouse] --- Selects the line under the + input mouse event.} + @item{@mapdesc[start-macro key] -- Starts building a keyboard macro} + @item{@mapdesc[end-macro key] --- Stops building a keyboard macro} + @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} + @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting mode}] + + These functions are bound to the following keys + (C = control, S = shift, A = alt, M = ``meta'', D = command): + + @itemize[ + @item{C-g : ``ring-bell''} + @item{M-C-g : ``ring-bell''} + @item{C-c C-g : ``ring-bell''} + @item{C-x C-g : ``ring-bell''} + @item{C-p : ``previous-line''} + @item{S-C-p : ``select-previous-line''} + @item{C-n : ``next-line''} + @item{S-C-n : ``select-next-line''} + @item{C-e : ``end-of-line''} + @item{S-C-e : ``select-to-end-of-line''} + @item{D-RIGHT : ``end-of-line''} + @item{S-D-RIGHT : ``select-to-end-of-line''} + @item{M-RIGHT : ``end-of-line''} + @item{S-M-RIGHT : ``select-to-end-of-line''} + @item{C-a : ``beginning-of-line''} + @item{S-C-a : ``select-to-beginning-of-line''} + @item{D-LEFT : ``beginning-of-line''} + @item{D-S-LEFT : ``select-to-beginning-of-line''} + @item{M-LEFT : ``beginning-of-line''} + @item{M-S-LEFT : ``select-to-beginning-of-line''} + @item{C-h : ``delete-previous-character''} + @item{C-d : ``delete-next-character''} + @item{C-f : ``forward-character''} + @item{S-C-f : ``select-forward-character''} + @item{C-b : ``backward-character''} + @item{S-C-b : ``select-backward-character''} + @item{M-f : ``forward-word''} + @item{S-M-f : ``select-forward-word''} + @item{A-RIGHT : ``forward-word''} + @item{A-S-RIGHT : ``forward-select-word''} + @item{M-b : ``backward-word''} + @item{S-M-b : ``select-backward-word''} + @item{A-LEFT : ``backward-word''} + @item{A-S-LEFT : ``backward-select-word''} + @item{M-d : ``kill-word''} + @item{M-DELETE : ``backward-kill-word''} + @item{M-c : ``capitalize-word''} + @item{M-u : ``upcase-word''} + @item{M-l : ``downcase-word''} + @item{M-< : ``beginning-of-file''} + @item{S-M-< : ``select-to-beginning-of-file''} + @item{M-> : ``end-of-file''} + @item{S-M-> : ``select-to-end-of-file''} + @item{C-v : ``next-page''} + @item{S-C-v : ``select-next-page''} + @item{M-v : ``previous-page''} + @item{S-M-v : ``select-previous-page''} + @item{C-l : ``center-view-on-line''} + @item{C-k : ``delete-to-end-of-line''} + @item{C-y : ``paste-clipboard'' (Except Windows)} + @item{A-v : ``paste-clipboard''} + @item{D-v : ``paste-clipboard''} + @item{C-_ : ``undo''} + @item{C-x u : ``undo''} + @item{C-+ : ``redo''} + @item{C-w : ``cut-clipboard''} + @item{M-w : ``copy-clipboard''} + @item{C-x C-s : ``save-file''} + @item{C-x C-w : ``save-file-as''} + @item{C-x C-f : ``load-file''} + @item{C-s : ``find-string''} + @item{C-r : ``find-string-reverse''} + @item{M-% : ``find-string-replace''} + @item{SPACE : ``collapse-space''} + @item{M-Backslash : ``remove-space''} + @item{C-x C-o : ``collapse-newline''} + @item{C-o : ``open-line''} + @item{C-t : ``transpose-chars''} + @item{M-t : ``transpose-words''} + @item{C-SPACE : ``toggle-anchor''} + @item{M-g : ``goto-line''} + @item{M-p : ``goto-position''} + @item{LEFTBUTTONTRIPLE : ``select-click-line''} + @item{LEFTBUTTONDOUBLE : ``select-click-word''} + @item{RIGHTBUTTON : ``copy-click-region''} + @item{RIGHTBUTTONDOUBLE : ``cut-click-region''} + @item{MIDDLEBUTTON : ``paste-click-region''} + @item{C-RIGHTBUTTON : ``copy-clipboard''} + @item{INSERT : ``toggle-overwrite''} + @item{M-o : ``toggle-overwrite''}]}) + (proc-doc/names keymap:setup-search ((is-a?/c keymap%) . -> . void?) (keymap) @{This extends a @scheme[keymap%] with the bindings for searching.}) - + (proc-doc/names keymap:set-chained-keymaps ((is-a?/c keymap:aug-keymap<%>) @@ -1296,9 +1274,8 @@ void?) (keymap children-keymaps) @{Sets @scheme[keymap]'s chained keymaps to @scheme[children-keymaps], - unchaining any keymaps that are currently chained to - @scheme[keymap].}) - + unchaining any keymaps that are currently chained to @scheme[keymap].}) + (proc-doc/names keymap:remove-chained-keymap ((is-a?/c editor<%>) @@ -1307,15 +1284,15 @@ void?) (editor keymap) @{Removes @scheme[keymap] from the keymaps chained to @scheme[editor]. - Also (indirectly) removes all keymaps chained to @scheme[keymap] - from @scheme[editor], since they are removed when unchaining - @scheme[keymap] itself. - - Each of the keymaps chained to @scheme[editor] must be an - @scheme[keymap:aug-keymap%] and @scheme[keymap] cannot be the result - of @scheme[(send editor get-keymap)] That is, @scheme[keymap] must - be chained to some keymap attached to the editor.}) - + Also (indirectly) removes all keymaps chained to @scheme[keymap] from + @scheme[editor], since they are removed when unchaining @scheme[keymap] + itself. + + Each of the keymaps chained to @scheme[editor] must be an + @scheme[keymap:aug-keymap%] and @scheme[keymap] cannot be the result of + @scheme[(send editor get-keymap)] That is, @scheme[keymap] must be chained + to some keymap attached to the editor.}) + (proc-doc/names scheme:text-balanced? (->* ((is-a?/c text%)) @@ -1323,140 +1300,135 @@ boolean?) ((text) ((start 0) (end #f))) - @{Determines if the range in the editor from @scheme[start] to - @scheme[end] in @scheme[text] has at least one complete s-expression and - there are no incomplete s-expressions. If - @scheme[end] is @scheme[#f], it defaults to the last position of the - @scheme[text]. The designation ``complete'' is defined to be something that does not - cause @racket[read] to raise a @racket[exn:fail:read:eof?] exception, - so there may be all kinds of strange read-level (not to speak of parse level) - errors in the expressions. - - The implementation of this function creates a port with - @scheme[open-input-text-editor] and then uses @racket[read] to parse the - range of the buffer.}) - + @{Determines if the range in the editor from @scheme[start] to @scheme[end] + in @scheme[text] has at least one complete s-expression and there are no + incomplete s-expressions. If @scheme[end] is @scheme[#f], it defaults to + the last position of the @scheme[text]. The designation ``complete'' is + defined to be something that does not cause @racket[read] to raise a + @racket[exn:fail:read:eof?] exception, so there may be all kinds of strange + read-level (not to speak of parse level) errors in the expressions. + + The implementation of this function creates a port with + @scheme[open-input-text-editor] and then uses @racket[read] to parse the + range of the buffer.}) + (proc-doc/names scheme:add-preferences-panel (-> void?) () @{Adds a tabbing preferences panel to the preferences dialog.}) - + (proc-doc/names scheme:get-keymap (-> (is-a?/c keymap%)) () @{Returns a keymap with binding suitable for Racket.}) - + (proc-doc/names scheme:add-coloring-preferences-panel (-> any) () - @{ - Installs the ``Racket'' preferences panel in the ``Syntax Coloring'' - section.}) - + @{Installs the ``Racket'' preferences panel in the ``Syntax Coloring'' + section.}) + (proc-doc/names scheme:get-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () - @{Returns - a table mapping from symbols - (naming the categories that the online colorer uses for Racket mode coloring) to their colors. + @{Returns a table mapping from symbols (naming the categories that the online + colorer uses for Racket mode coloring) to their colors. These symbols are suitable for input to @scheme[scheme:short-sym->pref-name] and @scheme[scheme:short-sym->style-name]. See also @scheme[scheme:get-white-on-black-color-prefs-table].}) - + (proc-doc/names scheme:get-white-on-black-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () - @{Returns - a table mapping from symbols - (naming the categories that the online colorer uses for Racket mode coloring) to their colors when - the user chooses the white-on-black mode in the preferences dialog. + @{Returns a table mapping from symbols (naming the categories that the online + colorer uses for Racket mode coloring) to their colors when the user + chooses the white-on-black mode in the preferences dialog. See also @scheme[scheme:get-color-prefs-table].}) - + (proc-doc/names scheme:short-sym->pref-name (symbol? . -> . symbol?) (short-sym) - @{Builds the symbol naming the preference from one of the symbols in - the table returned by @scheme[scheme:get-color-prefs-table].}) - + @{Builds the symbol naming the preference from one of the symbols in the + table returned by @scheme[scheme:get-color-prefs-table].}) + (proc-doc/names scheme:short-sym->style-name (symbol? . -> . string?) (short-sym) - @{Builds the symbol naming the editor style from one of the symbols in - the table returned by @scheme[scheme:get-color-prefs-table]. This - style is a named style in the style list returned by - @scheme[editor:get-standard-style-list].}) - + @{Builds the symbol naming the editor style from one of the symbols in the + table returned by @scheme[scheme:get-color-prefs-table]. This style is a + named style in the style list returned by + @scheme[editor:get-standard-style-list].}) + (proc-doc/names scheme:get-wordbreak-map (-> (is-a?/c editor-wordbreak-map%)) () - @{This method returns a @scheme[editor-wordbreak-map%] that is suitable - for Racket.}) - + @{This method returns a @scheme[editor-wordbreak-map%] that is suitable for + Racket.}) + (proc-doc/names scheme:init-wordbreak-map ((is-a?/c keymap%) . -> . void?) (key) @{Initializes the workdbreak map for @scheme[keymap].}) - + (proc-doc/names scheme:setup-keymap ((is-a?/c keymap%) . -> . void?) (keymap) @{Initializes @scheme[keymap] with Racket-mode keybindings.}) - + (proc-doc/names editor:set-default-font-color (-> (is-a?/c color%) void?) (color) @{Sets the color of the style named - @scheme[editor:get-default-color-style-name].}) - + @scheme[editor:get-default-color-style-name].}) + (proc-doc/names editor:get-default-color-style-name (-> string?) () @{The name of the style (in the list returned by - @scheme[editor:get-standard-style-list]) that holds the default - color.}) - + @scheme[editor:get-standard-style-list]) that holds the default color.}) + (proc-doc/names editor:set-standard-style-list-delta (string? (is-a?/c style-delta%) . -> . void?) (name delta) @{Finds (or creates) the style named by @scheme[name] in the result of - @scheme[editor:get-standard-style-list] and sets its delta to - @scheme[delta]. - - If the style named by @scheme[name] is already in the style list, it - must be a delta style.}) - + @scheme[editor:get-standard-style-list] and sets its delta to + @scheme[delta]. + + If the style named by @scheme[name] is already in the style list, it must + be a delta style.}) + (proc-doc/names editor:set-standard-style-list-pref-callbacks (-> any) () - @{Installs the font preference callbacks that update the style list - returned by @scheme[editor:get-standard-style-list] based on the - font preference symbols.}) - + @{Installs the font preference callbacks that update the style list returned + by @scheme[editor:get-standard-style-list] based on the font preference + symbols.}) + (proc-doc/names editor:get-standard-style-list (-> (is-a?/c style-list%)) () @{Returns a style list that is used for all instances of - @scheme[editor:standard-style-list%].}) - + @scheme[editor:standard-style-list%].}) + (proc-doc/names editor:add-after-user-keymap (-> (is-a?/c keymap%) (listof (is-a?/c keymap%)) (listof (is-a?/c keymap%))) @@ -1465,62 +1437,60 @@ same relative order, but also with @scheme[keymap], where @scheme[keymap] is now the first keymap after @scheme[keymap:get-user] (if that keymap is in the list.)}) - + (proc-doc/names color-model:rgb->xyz (number? number? number? . -> . color-model:xyz?) (r g b) - @{Converts a color represented as a red-green-blue tuple (each value - from 0 to 255) into an XYZ tuple. This describes a point in the CIE - XYZ color space.}) - + @{Converts a color represented as a red-green-blue tuple (each value from 0 + to 255) into an XYZ tuple. This describes a point in the CIE + XYZ color space.}) + (proc-doc/names color-model:rgb-color-distance (number? number? number? number? number? number? . -> . number?) (red-a green-a blue-a red-b green-b blue-b) - @{This calculates a distance between two colors. The smaller the - distance, the closer the colors should appear to the human eye. A - distance of 10 is reasonably close that it could be called the same - color. - - This function is not symmetric in red, green, and blue, so it is - important to pass red, green, and blue components of the colors in - the proper order. The first three arguments are red, green and - blue for the first color, respectively, and the second three - arguments are red green and blue for the second color, - respectively.}) - + @{This calculates a distance between two colors. The smaller the distance, + the closer the colors should appear to the human eye. A distance of 10 is + reasonably close that it could be called the same color. + + This function is not symmetric in red, green, and blue, so it is important + to pass red, green, and blue components of the colors in the proper order. + The first three arguments are red, green and blue for the first color, + respectively, and the second three arguments are red green and blue for the + second color, respectively.}) + (proc-doc/names color-model:xyz->rgb (number? number? number? . -> . (list/c number? number? number?)) (x y z) - @{Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of - values representing an RGB-tuple.}) - + @{Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of values + representing an RGB-tuple.}) + (proc-doc/names color-model:xyz? (any/c . -> . boolean?) (val) @{Determines if @scheme[val] an xyz color record.}) - + (proc-doc/names color-model:xyz-x (color-model:xyz? . -> . number?) (xyz) @{Extracts the x component of @scheme[xyz].}) - + (proc-doc/names color-model:xyz-y (color-model:xyz? . -> . number?) (xyz) @{Extracts the y component of @scheme[xyz].}) - + (proc-doc/names color-model:xyz-z (color-model:xyz? . -> . number?) (xyz) @{Extracts the z component of @scheme[xyz].}) - + (proc-doc/names color-prefs:set-default/color-scheme (-> symbol? @@ -1528,14 +1498,13 @@ (or/c (is-a?/c color%) string?) void?) (pref-sym black-on-white-color white-on-black-color) - @{Registers a preference whose value will be updated when the user - clicks on one of the color scheme default settings in the - preferences dialog. - - Also calls @scheme[preferences:set-default] and - @scheme[preferences:set-un/marshall] with appropriate arguments to - register the preference.}) - + @{Registers a preference whose value will be updated when the user clicks on + one of the color scheme default settings in the preferences dialog. + + Also calls @scheme[preferences:set-default] and + @scheme[preferences:set-un/marshall] with appropriate arguments to register + the preference.}) + (proc-doc/names color-prefs:register-color-preference (->* (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%))) @@ -1543,78 +1512,78 @@ void?) ((pref-name style-name color/sd) ((white-on-black-color #f))) - @{This function registers a color preference and initializes the style - list returned from @scheme[editor:get-standard-style-list]. In - particular, it calls @scheme[preferences:set-default] and - @scheme[preferences:set-un/marshall] to install the pref for - @scheme[pref-name], using @scheme[color/sd] as the default - color. The preference is bound to a @scheme[style-delta%], and - initially the @scheme[style-delta%] changes the foreground color to - @scheme[color/sd], unless @scheme[color/sd] is a style delta - already, in which case it is just used directly. Then, it calls - @scheme[editor:set-standard-style-list-delta] passing the - @scheme[style-name] and the current value of the preference - @scheme[pref-name]. - - Finally, it adds calls @scheme[preferences:add-callback] to set a - callback for @scheme[pref-name] that updates the style list when the - preference changes. - - If @scheme[white-on-black-color] is not @scheme[#f], then the color - of the @scheme[color/sd] argument is used in combination with - @scheme[white-on-black-color] to register this preference with - @scheme[color-prefs:set-default/color-scheme].}) - + @{This function registers a color preference and initializes the style list + returned from @scheme[editor:get-standard-style-list]. In particular, it + calls @scheme[preferences:set-default] and + @scheme[preferences:set-un/marshall] to install the pref for + @scheme[pref-name], using @scheme[color/sd] as the default color. The + preference is bound to a @scheme[style-delta%], and initially the + @scheme[style-delta%] changes the foreground color to @scheme[color/sd], + unless @scheme[color/sd] is a style delta already, in which case it is just + used directly. Then, it calls + @scheme[editor:set-standard-style-list-delta] passing the + @scheme[style-name] and the current value of the preference + @scheme[pref-name]. + + Finally, it adds calls @scheme[preferences:add-callback] to set a callback + for @scheme[pref-name] that updates the style list when the preference + changes. + + If @scheme[white-on-black-color] is not @scheme[#f], then the color of the + @scheme[color/sd] argument is used in combination with + @scheme[white-on-black-color] to register this preference with + @scheme[color-prefs:set-default/color-scheme].}) + (proc-doc/names color-prefs:add-background-preferences-panel (-> void?) () @{Adds a preferences panel that configures the background color for - @scheme[editor:basic-mixin].}) - + @scheme[editor:basic-mixin].}) + (proc-doc/names color-prefs:add-to-preferences-panel (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (name func) - @{Calls @scheme[func] with the subpanel of the preferences coloring - panel that corresponds to @scheme[name].}) - + @{Calls @scheme[func] with the subpanel of the preferences coloring panel + that corresponds to @scheme[name].}) + (proc-doc/names color-prefs:build-color-selection-panel ((is-a?/c area-container<%>) symbol? string? string? . -> . void?) (parent pref-sym style-name example-text) - @{Builds a panel with a number of controls for configuring a font: the - color and check boxes for bold, italic, and underline. The - @scheme[parent] argument specifies where the panel will be placed. - The @scheme[pref-sym] should be a preference - (suitable for use with @scheme[preferences:get] and @scheme[preferences:set]). - The - @scheme[style-name] specifies the name of a style in the style list - returned from @scheme[editor:get-standard-style-list] and - @scheme[example-text] is shown in the panel so users can see the - results of their configuration.}) - + @{Builds a panel with a number of controls for configuring a font: the color + and check boxes for bold, italic, and underline. The @scheme[parent] + argument specifies where the panel will be placed. The @scheme[pref-sym] + should be a preference (suitable for use with @scheme[preferences:get] and + @scheme[preferences:set]). The @scheme[style-name] specifies the name of a + style in the style list returned from + @scheme[editor:get-standard-style-list] and @scheme[example-text] is shown + in the panel so users can see the results of their configuration.}) + (proc-doc/names color-prefs:marshall-style-delta (-> (is-a?/c style-delta%) printable/c) (style-delta) @{Builds a printed representation for a style-delta.}) - + (proc-doc/names color-prefs:unmarshall-style-delta (-> printable/c (or/c false/c (is-a?/c style-delta%))) (marshalled-style-delta) - @{Builds a style delta from its printed representation. Returns - @scheme[#f] if the printed form cannot be parsed.}) - + @{Builds a style delta from its printed representation. Returns @scheme[#f] + if the printed form cannot be parsed.}) + (proc-doc/names color-prefs:white-on-black (-> any) () - @{Sets the colors registered by @scheme[color-prefs:register-color-preference] to their white-on-black variety. }) - + @{Sets the colors registered by @scheme[color-prefs:register-color-preference] + to their white-on-black variety.}) + (proc-doc/names color-prefs:black-on-white (-> any) () - @{Sets the colors registered by @scheme[color-prefs:register-color-preference] to their black-on-white variety. })) + @{Sets the colors registered by @scheme[color-prefs:register-color-preference] + to their black-on-white variety.})) From 7d81183831d644de8525168c74e10ca7f8db5b7b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 00:11:36 -0400 Subject: [PATCH 017/462] Fix some typos original commit: f04a60da61342d72247f7c68eb54f2ac999dce7f --- collects/framework/main.rkt | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c504b51a..71a01f89 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -115,7 +115,7 @@ (manuals) @{Returns the list of keywords for the manuals from @scheme[manuals] by extracting all of the documented exports of the manuals. The symbols are - meant to be module paths, eg the quoted form of the argument to + meant to be module paths, e.g., the quoted form of the argument to @scheme[require]. If @scheme[manuals] is false, then all of the documented names are used.}) @@ -131,7 +131,7 @@ number-snip:make-repeating-decimal-snip (number? boolean? . -> . (is-a?/c snip%)) (num show-prefix?) - @{Makes a number snip that shows the decimal expansion for @scheme[number] + @{Makes a number snip that shows the decimal expansion for @scheme[number]. The boolean indicates if a @litchar{#e} prefix appears on the number. See also @scheme[number-snip:make-fraction-snip].}) @@ -150,14 +150,14 @@ version:add-spec (any/c any/c . -> . void?) (spec revision) - @{These two values are appended to the version string. @scheme[write] is - used to transform them to strings. For example: + @{The two values are appended to the version string. @scheme[write] is used + to transform them to strings. For example: @scheme[(version:add-spec 's 1)] in version 205 will make the version string be @litchar{205s1}. The - symbols @scheme['f] and @scheme['d] are used internally for framework and - drscheme revisions.}) + symbols @scheme['f] and @scheme['d] were used internally for framework and + drscheme revisions in the past.}) (proc-doc/names version:version @@ -397,7 +397,7 @@ @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if none of the ``can?'' callbacks return @scheme[#f],} @item{invokes @scheme[exit:on-exit] and then} - @item{queues a callback that calls @scheme[exit] (a mzscheme procedure) + @item{queues a callback that calls @scheme[exit] (a racket procedure) and (if @scheme[exit] returns) sets the result of @scheme[exit:exiting?] back to @scheme[#t].}]}) @@ -604,7 +604,7 @@ (size-pref-sym width height) @{Initializes a preference for the @scheme[frame:size-pref] mixin. - The first argument should be the preferences symbol, and the second an + The first argument should be the preferences symbol, and the second and third should be the default width and height, respectively.}) (proc-doc/names @@ -650,7 +650,7 @@ @scheme[frame:basic-mixin]. @itemize[ @item{If it is @scheme[#f], then its value is ignored.} - @item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is + @item{If it is a @scheme[bitmap%], then the @method[frame% set-icon] is called with the bitmap, the result of invoking the @scheme[bitmap% get-loaded-mask] method, and @scheme['both].} @item{If it is a pair of bitmaps, then the @method[frame% set-icon] @@ -718,7 +718,7 @@ handler:handler-handler (handler:handler? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (handler) - @{Extracs the handler's handling function.}) + @{Extracts the handler's handling function.}) (proc-doc/names handler:insert-format-handler @@ -1001,7 +1001,7 @@ keymap:call/text-keymap-initializer ((-> any/c) . -> . any/c) (thunk-proc) - @{Thus function parameterizes the call to @scheme[thunk-proc] by setting the + @{This function parameterizes the call to @scheme[thunk-proc] by setting the keymap-initialization procedure (see @scheme[current-text-keymap-initializer]) to install the framework's standard text bindings.}) @@ -1029,7 +1029,7 @@ @item{@scheme["v"]: paste} @item{@scheme["a"]: select all}] where each key is prefixed with the menu-shortcut key, based on the - platform. Under unix, the shortcut is @scheme["a:"]; under windows the + platform. Under Unix, the shortcut is @scheme["a:"]; under windows the shortcut key is @scheme["c:"] and under MacOS, the shortcut key is @scheme["d:"].}) @@ -1067,7 +1067,7 @@ @{This prefixes a key with all of the different meta prefixes and returns a list of the prefixed strings. - takes a keymap, a base key specification, and a function name; it prefixes + Takes a keymap, a base key specification, and a function name; it prefixes the base key with all ``meta'' combination prefixes, and installs the new combinations into the keymap. For example, @scheme[(keymap:send-map-function-meta keymap "a" func)] maps @@ -1104,9 +1104,7 @@ keymap:setup-global ((is-a?/c keymap%) . -> . void?) (keymap) - @{This extends a @scheme[keymap%] with the general bindings. - - This function extends a @scheme[keymap%] with the following functions: + @{This function extends a @scheme[keymap%] with the following functions: @itemize[ @item{@mapdesc[ring-bell any] --- Rings the bell (using @scheme[bell]) and removes the search panel from the frame, if there.} @@ -1158,7 +1156,7 @@ the clipboard.} @item{@mapdesc[cut-clipboard mouse] --- Cuts the current selection to the clipboard.} - @item{@mapdesc[paste-clipboard mouse] --- Patses the clipboard to the + @item{@mapdesc[paste-clipboard mouse] --- Pastes the clipboard to the current selection.} @item{@mapdesc[copy-click-region mouse] --- Copies the region between the caret and the input mouse event.} @@ -1170,8 +1168,8 @@ input mouse event.} @item{@mapdesc[select-click-line mouse] --- Selects the line under the input mouse event.} - @item{@mapdesc[start-macro key] -- Starts building a keyboard macro} - @item{@mapdesc[end-macro key] --- Stops building a keyboard macro} + @item{@mapdesc[start-macro key] -- Starts recording a keyboard macro} + @item{@mapdesc[end-macro key] --- Stops recording a keyboard macro} @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting mode}] From b0135206c38c58441667dd6202b099a57d0d2cb7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 16:10:55 -0400 Subject: [PATCH 018/462] Lots of "~e" to "~.s" changes. original commit: 606b7f60dc597a6870efc11364e1dd3e1a8b4a1b --- collects/framework/preferences.rkt | 2 +- collects/framework/private/color.rkt | 6 +++--- collects/framework/test.rkt | 8 ++++---- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index dbec9584..25bd438b 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -141,7 +141,7 @@ the state transitions / contracts are: (let ([default (hash-ref defaults p)]) (unless ((default-checker default) value) (error 'preferences:set - "tried to set preference ~e to ~e but it does not meet test from preferences:set-default" + "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" p value)) (check-callbacks p value) (hash-set! preferences p value))] diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index f6a5dd6d..281844f3 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -918,15 +918,15 @@ added get-regions (let* ((x null) (f (λ (a b c) (set! x (cons (list a b c) x))))) (send (lexer-state-tokens ls) for-each f) - (printf "tokens: ~e~n" (reverse x)) + (printf "tokens: ~.s~n" (reverse x)) (set! x null) (send (lexer-state-invalid-tokens ls) for-each f) - (printf "invalid-tokens: ~e~n" (reverse x)) + (printf "invalid-tokens: ~.s~n" (reverse x)) (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" (lexer-state-start-pos ls) (lexer-state-current-pos ls) (lexer-state-invalid-tokens-start ls)) - (printf "parens: ~e~n" (car (send (lexer-state-parens ls) test))))) + (printf "parens: ~.s~n" (car (send (lexer-state-parens ls) test))))) lexer-states)) ;; ------------------------- Callbacks to Override ---------------------- diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index ac0c21c7..2fc91530 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -267,7 +267,7 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~e in active frame" + "no object of class ~a named ~.s in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] @@ -289,11 +289,11 @@ [ctrl (find-ctrl)]) (cond [(not (send ctrl is-shown?)) - (error error-tag "control ~e is not shown (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.s is not shown (label ~e)" ctrl (send ctrl get-label))] [(not (send ctrl is-enabled?)) - (error error-tag "control ~e is not enabled (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.s is not enabled (label ~e)" ctrl (send ctrl get-label))] [(not (in-active-frame? ctrl)) - (error error-tag "control ~e is not in active frame (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.s is not in active frame (label ~e)" ctrl (send ctrl get-label))] [else (update-control ctrl) (send ctrl command event) From 2c1b48d3c42b51afa4cc8affdd7572399178907d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 17:16:32 -0400 Subject: [PATCH 019/462] Change a bunch of "~%" and "~n" in format strings to "\n". original commit: 7dc4d2e5a63ab416d90e44d7bf75cb5593329909 --- collects/framework/preferences.rkt | 2 +- collects/framework/private/color-model.rkt | 6 +- collects/framework/private/color.rkt | 40 +++++------ collects/framework/private/editor.rkt | 4 +- .../framework/private/gen-standard-menus.rkt | 4 +- collects/framework/private/panel.rkt | 2 +- collects/framework/private/preferences.rkt | 2 +- collects/framework/splash.rkt | 4 +- collects/framework/test.rkt | 2 +- collects/tests/gracket/item.rkt | 64 ++++++++--------- collects/tests/gracket/windowing.rktl | 68 +++++++++---------- 11 files changed, 99 insertions(+), 99 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 25bd438b..9c74cff4 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -244,7 +244,7 @@ the state transitions / contracts are: (pref-can-init? p)) (let ([default-okay? (checker default-value)]) (unless default-okay? - (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" + (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t\n" p checker default-okay? default-value))) (unless (= (length aliases) (length rewrite-aliases)) diff --git a/collects/framework/private/color-model.rkt b/collects/framework/private/color-model.rkt index 9a45c779..a18e0152 100644 --- a/collects/framework/private/color-model.rkt +++ b/collects/framework/private/color-model.rkt @@ -192,7 +192,7 @@ (,(xyz-z xyz-white))))]) (apply values (car (transpose sigmas))))) - ;; (printf "should be equal to xyz-white: ~n~a~n" + ;; (printf "should be equal to xyz-white: \n~a\n" ;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b)))) (define rgb->xyz-matrix @@ -203,13 +203,13 @@ (define xyz->rgb-matrix (matrix-invert rgb->xyz-matrix)) - ;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) + ;;(printf "should be identity: \n~a\n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) (define (rgb->xyz r g b) (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) ;;(print-struct #t) - ;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255)) + ;; (printf "should be xyz-white: \n~a\n" (rgb->xyz 255 255 255)) (define (xyz->rgb x y z) (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 281844f3..25ee0731 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -286,7 +286,7 @@ added get-regions (enable-suspend #t)))]) (unless (eq? 'eof type) (enable-suspend #f) - #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) + #; (printf "~a 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))) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) @@ -418,11 +418,11 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) - #;(printf "revision ~a~n" (get-revision-number)) + #;(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") + #;(printf "new coroutine\n") (set! tok-cor (coroutine (λ (enable-suspend) @@ -450,19 +450,19 @@ added get-regions (format "exception in colorer thread: ~s" exn) exn)) (set! tok-cor #f)))) - #;(printf "begin lexing~n") + #;(printf "begin lexing\n") (when (coroutine-run 10 tok-cor) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states))) - #;(printf "end lexing~n") - #;(printf "begin coloring~n") + #;(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"))) + #;(printf "end coloring\n"))) (define/private (colorer-callback) (cond @@ -643,7 +643,7 @@ added get-regions ;; possible. (define/private match-parens (lambda ([just-clear? #f]) - ;;(printf "(match-parens ~a)~n" just-clear?) + ;;(printf "(match-parens ~a)\n" just-clear?) (when (and (not in-match-parens?) ;; Trying to match open parens while the ;; background thread is going slows it down. @@ -918,21 +918,21 @@ added get-regions (let* ((x null) (f (λ (a b c) (set! x (cons (list a b c) x))))) (send (lexer-state-tokens ls) for-each f) - (printf "tokens: ~.s~n" (reverse x)) + (printf "tokens: ~.s\n" (reverse x)) (set! x null) (send (lexer-state-invalid-tokens ls) for-each f) - (printf "invalid-tokens: ~.s~n" (reverse x)) - (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" + (printf "invalid-tokens: ~.s\n" (reverse x)) + (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a\n" (lexer-state-start-pos ls) (lexer-state-current-pos ls) (lexer-state-invalid-tokens-start ls)) - (printf "parens: ~.s~n" (car (send (lexer-state-parens ls) test))))) + (printf "parens: ~.s\n" (car (send (lexer-state-parens ls) test))))) lexer-states)) ;; ------------------------- Callbacks to Override ---------------------- (define/override (lock x) - ;;(printf "(lock ~a)~n" x) + ;;(printf "(lock ~a)\n" x) (super lock x) (when (and restart-callback (not x)) (set! restart-callback #f) @@ -940,25 +940,25 @@ added get-regions (define/override (on-focus on?) - ;;(printf "(on-focus ~a)~n" on?) + ;;(printf "(on-focus ~a)\n" on?) (super on-focus on?) (match-parens (not on?))) (define/augment (after-edit-sequence) - ;;(printf "(after-edit-sequence)~n") + ;;(printf "(after-edit-sequence)\n") (when (has-focus?) (match-parens)) (inner (void) after-edit-sequence)) (define/augment (after-set-position) - ;;(printf "(after-set-position)~n") + ;;(printf "(after-set-position)\n") (unless (local-edit-sequence?) (when (has-focus?) (match-parens))) (inner (void) after-set-position)) (define/augment (after-change-style a b) - ;;(printf "(after-change-style)~n") + ;;(printf "(after-change-style)\n") (unless (get-styles-fixed) (unless (local-edit-sequence?) (when (has-focus?) @@ -966,19 +966,19 @@ added get-regions (inner (void) after-change-style a b)) (define/augment (on-set-size-constraint) - ;;(printf "(on-set-size-constraint)~n") + ;;(printf "(on-set-size-constraint)\n") (unless (local-edit-sequence?) (when (has-focus?) (match-parens))) (inner (void) on-set-size-constraint)) (define/augment (after-insert edit-start-pos change-length) - ;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length) + ;;(printf "(after-insert ~a ~a)\n" edit-start-pos change-length) (do-insert/delete edit-start-pos change-length) (inner (void) after-insert edit-start-pos change-length)) (define/augment (after-delete edit-start-pos change-length) - ;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length) + ;;(printf "(after-delete ~a ~a)\n" edit-start-pos change-length) (do-insert/delete edit-start-pos (- change-length)) (inner (void) after-delete edit-start-pos change-length)) diff --git a/collects/framework/private/editor.rkt b/collects/framework/private/editor.rkt index 3c0b3537..0c8981b6 100644 --- a/collects/framework/private/editor.rkt +++ b/collects/framework/private/editor.rkt @@ -242,10 +242,10 @@ (unless (and (procedure? t) (= 0 (procedure-arity t))) (error 'editor:basic::run-after-edit-sequence - "expected procedure of arity zero, got: ~s~n" t)) + "expected procedure of arity zero, got: ~s\n" t)) (unless (or (symbol? sym) (not sym)) (error 'editor:basic::run-after-edit-sequence - "expected second argument to be a symbol or #f, got: ~s~n" + "expected second argument to be a symbol or #f, got: ~s\n" sym)) (if (refresh-delayed?) (if in-local-edit-sequence? diff --git a/collects/framework/private/gen-standard-menus.rkt b/collects/framework/private/gen-standard-menus.rkt index 120799bb..7e603022 100644 --- a/collects/framework/private/gen-standard-menus.rkt +++ b/collects/framework/private/gen-standard-menus.rkt @@ -125,7 +125,7 @@ (write-docs)) (define (write-docs) - (printf "writing to ~a~n" docs-menus.ss-filename) + (printf "writing to ~a\n" docs-menus.ss-filename) (call-with-output-file docs-menus.ss-filename (λ (port) (define (pop-out sexp) @@ -203,7 +203,7 @@ #:exists 'truncate)) (define (write-standard-menus.rkt) - (printf "writing to ~a~n" standard-menus.rkt-filename) + (printf "writing to ~a\n" standard-menus.rkt-filename) (call-with-output-file standard-menus.rkt-filename (λ (port) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index cfadd9d6..c2efa530 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -44,7 +44,7 @@ [(left top) 0] [(right bottom) (- total-size item-size)] [else (error 'place-children - "alignment spec is unknown ~a~n" spec)])))]) + "alignment spec is unknown ~a\n" spec)])))]) (map (λ (l) (let*-values ([(min-width min-height h-stretch? v-stretch?) (apply values l)] diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 03de7025..c1cddf1f 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -528,7 +528,7 @@ the state transitions / contracts are: (cond [(string? default) string?] [(number? default) number?] - [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)])) + [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])) (preferences:add-callback name (λ (p new-value) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index affbc869..0357046f 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -123,12 +123,12 @@ [(or (path? splash-draw-spec) (string? splash-draw-spec)) (unless (file-exists? splash-draw-spec) - (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec) + (fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec) (no-splash)) (set! splash-bitmap (make-object bitmap% splash-draw-spec)) (unless (send splash-bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec) + (fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec) (no-splash)) (send splash-canvas min-width (send splash-bitmap get-width)) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 2fc91530..9129bbd7 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -363,7 +363,7 @@ (loop (- n 1))))])))] [(number? state) (unless (send rb is-enabled? state) - (error 'test:set-radio-box! "item ~a is not enabled~n" state)) + (error 'test:set-radio-box! "item ~a is not enabled\n" state)) (send rb set-selection state)] [else (error 'test:set-radio-box! "expected a string or a number as second arg, got: ~e (other arg: ~e)" diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index f9ff3383..40be32ba 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -133,7 +133,7 @@ (if (not l) win l)))]) - (when noisy? (printf "~a~n" s)) + (when noisy? (printf "~a\n" s)) (send m set-label (substring s 0 (min 200 (string-length s)))))))) (define (add-click-intercept frame panel) @@ -146,7 +146,7 @@ (make-object menu-item% (format "Click on ~a" win) m (lambda (i e) (unless (eq? (send m get-popup-target) win) - (printf "Wrong owner!~n")))) + (printf "Wrong owner!\n")))) (send win popup-menu m (inexact->exact (send e get-x)) (inexact->exact (send e get-y))) @@ -160,7 +160,7 @@ [cc (make-object cursor% 'cross)]) (make-object check-box% "Control Bullseye Cursors" panel (lambda (c e) - (printf "~a~n" e) + (printf "~a\n" e) (if (send c get-value) (set! old (map (lambda (b) @@ -200,7 +200,7 @@ (override [on-demand (lambda () - (printf "Menu item ~a demanded~n" name))]) + (printf "Menu item ~a demanded\n" name))]) (sequence (apply super-init name args)))) @@ -239,7 +239,7 @@ (memq (send e get-event-type) '(menu-popdown menu-popdown-none))) (error "bad event object")) - (printf "popdown ok~n")))] + (printf "popdown ok\n")))] [make-callback (let ([id 0]) (lambda () @@ -297,7 +297,7 @@ (sequence (apply super-init args) (unless (ok?) - (printf "bitmap failure: ~s~n" args))))) + (printf "bitmap failure: ~s\n" args))))) (define (active-mixin %) (class % @@ -312,9 +312,9 @@ [on-subwindow-char (lambda args (or (apply pre-on args) (super on-subwindow-char . args)))] - [on-activate (lambda (on?) (printf "active: ~a~n" on?))] - [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] - [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) + [on-activate (lambda (on?) (printf "active: ~a\n" on?))] + [on-move (lambda (x y) (printf "moved: ~a ~a\n" x y))] + [on-size (lambda (x y) (printf "sized: ~a ~a\n" x y))]) (public* [set-info (lambda (ep) (set! pre-on (add-pre-note this ep)) @@ -331,10 +331,10 @@ (override [on-superwindow-show (lambda (on?) - (printf "~a ~a~n" name (if on? "show" "hide")))] + (printf "~a ~a\n" name (if on? "show" "hide")))] [on-superwindow-enable (lambda (on?) - (printf "~a ~a~n" name (if on? "on" "off")))]) + (printf "~a ~a\n" name (if on? "on" "off")))]) (sequence (apply super-init name args)))) @@ -952,7 +952,7 @@ (compare expect v (format "label search: ~a" string))))] [tell-ok (lambda () - (printf "ok~n"))]) + (printf "ok\n"))]) (private-field [temp-labels? #f] [use-menubar? #f] @@ -1180,7 +1180,7 @@ (unless (memq type types) (error (format "bad event type: ~a" type)))) (unless silent? - (printf "Callback Ok~n"))) + (printf "Callback Ok\n"))) (define (instructions v-panel file) (define c (make-object editor-canvas% v-panel)) @@ -1216,7 +1216,7 @@ (lambda (e) (check-callback-event b b e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (define e (make-object button% "Disable Test" p (lambda (c e) @@ -1227,7 +1227,7 @@ (thread (lambda () (sleep 0.5) (semaphore-post sema))) (yield sema) (when hit? - (printf "un-oh~n")) + (printf "un-oh\n")) (send b enable #t))))) (instructions p "button-steps.txt") (send f show #t)) @@ -1261,7 +1261,7 @@ (lambda (e) (check-callback-event cb cb e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (instructions p "checkbox-steps.txt") (send f show #t)) @@ -1333,7 +1333,7 @@ (lambda (rbe) (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t)) old-list) - (printf "All Ok~n"))) + (printf "All Ok\n"))) (instructions p "radiobox-steps.txt") (send f show #t)) @@ -1360,12 +1360,12 @@ (cond [(eq? (send e get-event-type) 'list-box-dclick) ; double-click - (printf "Double-click~n") + (printf "Double-click\n") (unless (send cx get-selection) (error "no selection for dclick"))] [else ; misc multi-selection - (printf "Changed: ~a~n" (if list? + (printf "Changed: ~a\n" (if list? (send cx get-selections) (send cx get-selection)))]) (check-callback-event c cx e commands #f))) @@ -1402,7 +1402,7 @@ (make-object button% "Visible Indices" p (lambda (b e) - (printf "top: ~a~nvisible count: ~a~n" + (printf "top: ~a\nvisible count: ~a\n" (send c get-first-visible-item) (send c number-of-visible-items)))))) (define cdp (make-object horizontal-panel% p)) @@ -1555,9 +1555,9 @@ (lambda (e) (check-callback-event c c e commands #t)) old-list) - (printf "content: ~s~n" actual-content) + (printf "content: ~s\n" actual-content) (when multi? - (printf "selections: ~s~n" (send c get-selections)))))) + (printf "selections: ~s\n" (send c get-selections)))))) (send c stretchable-width #t) (instructions p "choice-list-steps.txt") (send f show #t)) @@ -1570,7 +1570,7 @@ (define s (make-object slider% "Slide Me" -1 11 p (lambda (sl e) (check-callback-event s sl e commands #f) - (printf "slid: ~a~n" (send s get-value))) + (printf "slid: ~a\n" (send s get-value))) 3)) (define c (make-object button% "Check" p (lambda (c e) @@ -1578,7 +1578,7 @@ (lambda (e) (check-callback-event s s e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (define (simulate v) (let ([e (make-object control-event% 'slider)]) (send s set-value v) @@ -1634,13 +1634,13 @@ (define (handler get-this) (lambda (c e) (unless (eq? c (get-this)) - (printf "callback: bad item: ~a~n" c)) + (printf "callback: bad item: ~a\n" c)) (let ([t (send e get-event-type)]) (cond [(eq? t 'text-field) - (printf "Changed: ~a~n" (send c get-value))] + (printf "Changed: ~a\n" (send c get-value))] [(eq? t 'text-field-enter) - (printf "Return: ~a~n" (send c get-value))])))) + (printf "Return: ~a\n" (send c get-value))])))) (define f (make-frame frame% "Text Test")) (define p (make-object vertical-panel% f)) @@ -1701,7 +1701,7 @@ (send f set-status-text s)))] [on-scroll (lambda (e) - (when auto? (printf "Hey - on-scroll called for auto scrollbars~n")) + (when auto? (printf "Hey - on-scroll called for auto scrollbars\n")) (unless incremental? (on-paint)))] [init-auto-scrollbars (lambda x (set! auto? #t) @@ -1877,7 +1877,7 @@ (let ([c (car (send p get-children))]) (let-values ([(w h) (send c get-size)] [(cw ch) (send c get-client-size)]) - (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n" + (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}\n" c w h cw ch (- w cw) (- h ch) (send c min-width) (send c min-height))))) @@ -1962,7 +1962,7 @@ (make-object button% "Rename" p2 (lambda (b e) (send p set-item-label (quotient (send p get-number) 2) "Do&nut"))) (make-object button% "Labels" p2 (lambda (b e) - (printf "~s~n" + (printf "~s\n" (reverse (let loop ([i (send p get-number)]) (if (zero? i) @@ -2000,10 +2000,10 @@ (define (message-boxes parent) (define (check expected got) (unless (eq? expected got) - (fprintf (current-error-port) "bad result: - expected ~e, got ~e~n" + (fprintf (current-error-port) "bad result: - expected ~e, got ~e\n" expected got))) (define (big s) - (format "~a~n~a~n~a~n~a~n" s + (format "~a\n~a\n~a\n~a\n" s (make-string 500 #\x) (make-string 500 #\x) (make-string 500 #\x))) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 3c952a89..d6e2120e 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -39,7 +39,7 @@ (test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v)))))) (define (enable-tests f) - (printf "Enable ~a~n" f) + (printf "Enable ~a\n" f) (st #t f is-enabled?) (stv f enable #f) (st #f f is-enabled?) @@ -47,7 +47,7 @@ (st #t f is-enabled?)) (define (drop-file-tests f) - (printf "Drop File ~a~n" f) + (printf "Drop File ~a\n" f) (st #f f accept-drop-files) (stv f accept-drop-files #t) (st #t f accept-drop-files) @@ -55,7 +55,7 @@ (st #f f accept-drop-files)) (define (client->screen-tests f) - (printf "Client<->Screen ~a~n" f) + (printf "Client<->Screen ~a\n" f) (let-values ([(x y) (send f client->screen 0 0)]) (stvals '(0 0) f screen->client x y)) (let-values ([(x y) (send f screen->client 0 0)]) @@ -66,7 +66,7 @@ (stv f refresh)) (define (area-tests f sw? sh? no-stretch?) - (printf "Area ~a~n" f) + (printf "Area ~a\n" f) (let ([x (send f min-width)] [y (send f min-height)]) (st sw? f stretchable-width) @@ -76,7 +76,7 @@ (let-values ([(w h) (if no-stretch? (send f get-size) (values 0 0))]) - (printf "Size ~a x ~a~n" w h) + (printf "Size ~a x ~a\n" w h) (when no-stretch? (stv f min-width w) ; when we turn of stretchability, don't resize (stv f min-height h)) @@ -95,7 +95,7 @@ (define (containee-tests f sw? sh? m) (area-tests f sw? sh? #f) - (printf "Containee ~a~n" f) + (printf "Containee ~a\n" f) (st m f horiz-margin) (st m f vert-margin) (stv f horiz-margin 3) @@ -108,14 +108,14 @@ (stv f vert-margin m)) (define (container-tests f win?) - (printf "Container ~a~n" f) + (printf "Container ~a\n" f) (let-values ([(x y) (send f get-alignment)]) (stv f set-alignment 'right 'bottom) (stvals '(right bottom) f get-alignment) (stv f set-alignment x y))) (define (cursor-tests f) - (printf "Cursor ~a~n" f) + (printf "Cursor ~a\n" f) (let ([c (send f get-cursor)]) (stv f set-cursor c) (st c f get-cursor) @@ -131,7 +131,7 @@ (define (show-tests f) (unless (is-a? f dialog%) - (printf "Show ~a~n" f) + (printf "Show ~a\n" f) (let ([on? (send f is-shown?)]) (stv f show #f) (when on? @@ -193,7 +193,7 @@ (st #f f get-menu-bar))] [space-tests (lambda () - (printf "Spacing~n") + (printf "Spacing\n") (let ([b (send f border)]) (stv f border 25) (st 25 f border) @@ -209,14 +209,14 @@ (drop-file-tests f))] [client->screen-tests (lambda () - (printf "Client<->Screen~n") + (printf "Client<->Screen\n") (let-values ([(x y) (send f client->screen 0 0)]) (stvals '(0 0) f screen->client x y)) (let-values ([(x y) (send f screen->client 0 0)]) (stvals '(0 0) f client->screen x y)))] [container-tests (lambda () - (printf "Container~n") + (printf "Container\n") (area-tests f #t #t #t) (let-values ([(x y) (send f container-size null)]) (st x f min-width) @@ -238,15 +238,15 @@ (container-tests) (cursor-tests) - (printf "Init~n") + (printf "Init\n") (init-tests #f) (stv f show #t) (pause) - (printf "Show Init~n") + (printf "Show Init\n") (init-tests #t) (stv f show #f) (pause) - (printf "Hide Init~n") + (printf "Hide Init\n") (init-tests #f) (send f show #t) (pause) @@ -258,7 +258,7 @@ (stv f change-children values) - (printf "Iconize~n") + (printf "Iconize\n") (stv f iconize #t) (pause) (pause) @@ -272,7 +272,7 @@ (stv f maximize #f) (pause) - (printf "Move~n") + (printf "Move\n") (stv f move 34 37) (pause) (FAILS (st 34 f get-x)) @@ -280,7 +280,7 @@ (st 150 f get-width) (st 151 f get-height) - (printf "Resize~n") + (printf "Resize\n") (stv f resize 56 57) (pause) (FAILS (st 34 f get-x)) @@ -306,7 +306,7 @@ (cursor-tests) - (printf "Menu Bar~n") + (printf "Menu Bar\n") (let ([mb (make-object menu-bar% f)]) (st mb f get-menu-bar) (st f mb get-frame) @@ -320,11 +320,11 @@ (st null mb get-items) - (printf "Menu 1~n") + (printf "Menu 1\n") (let* ([m (make-object menu% "&File" mb)] [i m] [delete-enable-test (lambda (i parent empty) - (printf "Item~n") + (printf "Item\n") (st #f i is-deleted?) (st #t i is-enabled?) @@ -371,7 +371,7 @@ (st null m get-items) - (printf "Menu Items~n") + (printf "Menu Items\n") (let ([i1 (make-object menu-item% "&Plain" m (lambda (i e) (test-control-event e '(menu)) @@ -391,7 +391,7 @@ (lambda (i empty name) (delete-enable-test i m empty) - (printf "Shortcut~n") + (printf "Shortcut\n") (set! hit i) (stv i command (make-object control-event% 'menu)) (test name 'hit-command hit) @@ -437,7 +437,7 @@ 'done) - (printf "Menu 2~n") + (printf "Menu 2\n") (let* ([m2 (make-object menu% "&Edit" mb "Help Edit")] [i2 m2]) (st (list i i2) mb get-items) @@ -468,7 +468,7 @@ (define (test-controls parent frame) (define side-effect #f) - (printf "Buttons~n") + (printf "Buttons\n") (letrec ([b (make-object button% "&Button" parent @@ -484,7 +484,7 @@ (containee-window-tests b #f #f parent frame 2)) - (printf "Check Box~n") + (printf "Check Box\n") (letrec ([c (make-object check-box% "&Check Box" parent @@ -511,7 +511,7 @@ #t)]) (st #t c get-value)) - (printf "Radio Box~n") + (printf "Radio Box\n") (letrec ([r (make-object radio-box% "&Radio Box" (list "O&ne" "T&wo" "T&hree") @@ -586,7 +586,7 @@ '(vertical) 3)) - (printf "Gauge~n") + (printf "Gauge\n") (letrec ([g (make-object gauge% "&Gauge" 10 @@ -618,7 +618,7 @@ (containee-window-tests g #t #f parent frame 2)) - (printf "Slider~n") + (printf "Slider\n") (letrec ([s (make-object slider% "&Slider" -2 8 @@ -774,7 +774,7 @@ 'done-list)]) - (printf "Choice~n") + (printf "Choice\n") (letrec ([c (make-object choice% "&Choice" '("A" "B" "C & D") @@ -808,7 +808,7 @@ (let ([mk-list (lambda (style) - (printf "List Box: ~a~n" style) + (printf "List Box: ~a\n" style) (letrec ([l (make-object list-box% "&List Box" '("A" "B" "C & D") @@ -869,7 +869,7 @@ (let ([c (make-object canvas% parent '(hscroll vscroll))]) - (printf "Tab Focus~n") + (printf "Tab Focus\n") (st #f c accept-tab-focus) (stv c accept-tab-focus #t) (st #t c accept-tab-focus) @@ -880,7 +880,7 @@ ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) (let-values ([(w h) (send c get-virtual-size)] [(cw ch) (send c get-client-size)]) - (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch) + (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a\n" w h cw ch) (let ([check-scroll (lambda (xpos ypos) (let-values ([(x y) (send c get-view-start)]) @@ -958,7 +958,7 @@ 102)]) (let loop ([n 100]) (unless (zero? n) - (send e insert (format "line ~a~n" n)) + (send e insert (format "line ~a\n" n)) (loop (sub1 n)))) (st #f c allow-scroll-to-last) From 0f97692e427b0ee19082790e1c227ed7b16ddc28 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Aug 2010 12:10:48 -0400 Subject: [PATCH 020/462] More "~n" -> "\n" changes original commit: 8e0f8dd39c3744472b450021f003f9cbe8cbcb62 --- collects/mred/private/misc.rkt | 2 +- collects/mrlib/hierlist.rkt | 4 ++-- .../mrlib/private/aligned-pasteboard/alignment.rkt | 2 +- .../mrlib/private/aligned-pasteboard/tests/debug.rkt | 12 ++++++------ collects/mrlib/tab-choice.rkt | 2 +- collects/tests/gracket/draw.rkt | 2 +- collects/tests/gracket/mem.rktl | 8 ++++---- collects/tests/gracket/paramz.rktl | 2 +- collects/tests/gracket/testing.rktl | 10 +++++----- 9 files changed, 22 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/misc.rkt b/collects/mred/private/misc.rkt index 62f71937..964b66c7 100644 --- a/collects/mred/private/misc.rkt +++ b/collects/mred/private/misc.rkt @@ -30,7 +30,7 @@ (let loop () (let ([l (read-line p)]) (unless (eof-object? l) - (fprintf orig-err "~a~n" l) + (fprintf orig-err "~a\n" l) (loop))))) (lambda () (close-input-port p))))))]) (echo in) diff --git a/collects/mrlib/hierlist.rkt b/collects/mrlib/hierlist.rkt index d42fdcde..c02b527d 100644 --- a/collects/mrlib/hierlist.rkt +++ b/collects/mrlib/hierlist.rkt @@ -22,13 +22,13 @@ (when f (f i))))] [on-select (lambda (i) - (printf "Selected: ~a~n" + (printf "Selected: ~a\n" (if i (send (send i get-editor) get-flattened-text) i)))] [on-double-select (lambda (s) - (printf "Double-click: ~a~n" + (printf "Double-click: ~a\n" (send (send s get-editor) get-flattened-text)))]) (sequence (apply super-init args))) p)) diff --git a/collects/mrlib/private/aligned-pasteboard/alignment.rkt b/collects/mrlib/private/aligned-pasteboard/alignment.rkt index 1e5b78f5..2741e527 100644 --- a/collects/mrlib/private/aligned-pasteboard/alignment.rkt +++ b/collects/mrlib/private/aligned-pasteboard/alignment.rkt @@ -157,7 +157,7 @@ neck and it is the most readable solution. ($ dim x width stretchable-width?) ($ dim y height stretchable-height?)) others ...) - (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n" + (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))\n" x width stretchable-width? y height stretchable-height?) (rect-print others)])) diff --git a/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt b/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt index 32b6b3a7..3c18771b 100644 --- a/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt +++ b/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt @@ -26,12 +26,12 @@ (send snip get-margin l t r b) (printf "get-margin: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b))) - (printf "get-max-height: ~s~n" (send snip get-max-height)) - (printf "get-max-width: ~s~n" (send snip get-max-width)) - (printf "get-min-height: ~s~n" (send snip get-min-height)) - (printf "get-min-width: ~s~n" (send snip get-min-width)) - ;(printf "snip-width: ~s~n" (send pasteboard snip-width snip)) - ;(printf "snip-height: ~s~n" (send pasteboard snip-height snip)) + (printf "get-max-height: ~s\n" (send snip get-max-height)) + (printf "get-max-width: ~s\n" (send snip get-max-width)) + (printf "get-min-height: ~s\n" (send snip get-min-height)) + (printf "get-min-width: ~s\n" (send snip get-min-width)) + ;(printf "snip-width: ~s\n" (send pasteboard snip-width snip)) + ;(printf "snip-height: ~s\n" (send pasteboard snip-height snip)) )) ;;debug-pasteboard: -> (void) diff --git a/collects/mrlib/tab-choice.rkt b/collects/mrlib/tab-choice.rkt index 32ed3761..571b427d 100644 --- a/collects/mrlib/tab-choice.rkt +++ b/collects/mrlib/tab-choice.rkt @@ -46,7 +46,7 @@ [(left top) 0] [(right bottom) (- total-size item-size)] [else (error 'place-children - "alignment spec is unknown ~a~n" spec)])))]) + "alignment spec is unknown ~a\n" spec)])))]) (map (lambda (l) (let*-values ([(min-width min-height v-stretch? h-stretch?) (apply values l)] diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index d4b8fbf3..0af3b7f9 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -716,7 +716,7 @@ 0 0 w h mode color) (set! x (+ x w 10)))) - (printf "bad bitmap~n")))]) + (printf "bad bitmap\n")))]) ;; BB icon (do-one bb 'solid black) (let ([start x]) diff --git a/collects/tests/gracket/mem.rktl b/collects/tests/gracket/mem.rktl index 78ea4c90..9255637d 100644 --- a/collects/tests/gracket/mem.rktl +++ b/collects/tests/gracket/mem.rktl @@ -68,7 +68,7 @@ (sleep) (collect-garbage) (collect-garbage) - (printf "Thread: ~s Cycle: ~s~n" id n) + (printf "Thread: ~s Cycle: ~s\n" id n) ; (dump-object-stats) ; (if (and dump-stats? (= id 1)) ; (dump-memory-stats)) @@ -229,7 +229,7 @@ (map (lambda (x) (let ([v (weak-box-value (cdr x))]) (when v - (printf "~s ~s~n" (car x) v)))) + (printf "~s ~s\n" (car x) v)))) allocated) (void)) @@ -243,10 +243,10 @@ (if #f (thread (lambda () (read) - (printf "breaking~n") + (printf "breaking\n") (break-thread t) (thread-wait t) - (printf "done~n"))) + (printf "done\n"))) (void))) (define (do-test) diff --git a/collects/tests/gracket/paramz.rktl b/collects/tests/gracket/paramz.rktl index 02f362f3..2aef912e 100644 --- a/collects/tests/gracket/paramz.rktl +++ b/collects/tests/gracket/paramz.rktl @@ -93,7 +93,7 @@ (and (exn:fail? x) (regexp-match "shutdown" (exn-message x)))) (lambda (x) - (printf "got expected error: ~a~n" (exn-message x)) + (printf "got expected error: ~a\n" (exn-message x)) 'error)]) (parameterize ([current-eventspace e]) (t))))) diff --git a/collects/tests/gracket/testing.rktl b/collects/tests/gracket/testing.rktl index 0e3c9880..573a5e1c 100644 --- a/collects/tests/gracket/testing.rktl +++ b/collects/tests/gracket/testing.rktl @@ -12,7 +12,7 @@ (set! test-count (add1 test-count)) (unless (equal? expect got) (let ([s (format "~a: expected ~e; got ~e" name expect got)]) - (fprintf (current-error-port) "ERROR: ~a~n" s) + (fprintf (current-error-port) "ERROR: ~a\n" s) (set! errs (cons s errs))))) (define-syntax mismatch @@ -23,7 +23,7 @@ (test 'was-mismatch 'mismtach (with-handlers ([exn:fail:contract? (lambda (x) - (printf "~a~n" (exn-message x)) + (printf "~a\n" (exn-message x)) 'was-mismatch)] [exn:fail? values]) expr)))]))) @@ -51,11 +51,11 @@ (define (report-errs) (newline) (if (null? errs) - (printf "Passed all ~a tests~n" test-count) + (printf "Passed all ~a tests\n" test-count) (begin - (fprintf (current-error-port) "~a Error(s) in ~a tests~n" (length errs) test-count) + (fprintf (current-error-port) "~a Error(s) in ~a tests\n" (length errs) test-count) (for-each (lambda (s) - (fprintf (current-error-port) "~a~n" s)) + (fprintf (current-error-port) "~a\n" s)) (reverse errs))))) From 530ea01f13d58c8db820561f7dd632268ebfef7b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 27 Aug 2010 06:48:50 -0500 Subject: [PATCH 021/462] changed back some of Eli's ~e => ~.s changes original commit: 797df5e72c88b79f463ba049e15253ddd60b6111 --- collects/framework/test.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 9129bbd7..a4cd2425 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -267,7 +267,7 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~.s in active frame" + "no object of class ~a named ~.e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] @@ -289,11 +289,11 @@ [ctrl (find-ctrl)]) (cond [(not (send ctrl is-shown?)) - (error error-tag "control ~.s is not shown (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.e is not shown (label ~e)" ctrl (send ctrl get-label))] [(not (send ctrl is-enabled?)) - (error error-tag "control ~.s is not enabled (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.e is not enabled (label ~e)" ctrl (send ctrl get-label))] [(not (in-active-frame? ctrl)) - (error error-tag "control ~.s is not in active frame (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~.e is not in active frame (label ~e)" ctrl (send ctrl get-label))] [else (update-control ctrl) (send ctrl command event) From abc2561579e61df10f39238d999c5600b22ab2fd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 27 Aug 2010 07:25:04 -0500 Subject: [PATCH 022/462] ugh original commit: a13c251e5da944c8f1739544aea4676007138028 --- collects/framework/test.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index a4cd2425..cfad76ac 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -267,7 +267,7 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~.e in active frame" + "no object of class ~a named ~e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] @@ -289,11 +289,11 @@ [ctrl (find-ctrl)]) (cond [(not (send ctrl is-shown?)) - (error error-tag "control ~.e is not shown (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~e is not shown (label ~e)" ctrl (send ctrl get-label))] [(not (send ctrl is-enabled?)) - (error error-tag "control ~.e is not enabled (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~e is not enabled (label ~e)" ctrl (send ctrl get-label))] [(not (in-active-frame? ctrl)) - (error error-tag "control ~.e is not in active frame (label ~e)" ctrl (send ctrl get-label))] + (error error-tag "control ~e is not in active frame (label ~e)" ctrl (send ctrl get-label))] [else (update-control ctrl) (send ctrl command event) From 1947ad1240862f5050ee14d79af258fb4610eb7b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Sep 2010 12:52:43 -0500 Subject: [PATCH 023/462] added docs for the splash screen library in the framework original commit: 12ab498977f9f481187643c47ed6710c8a572d5b --- collects/framework/splash.rkt | 4 +- .../scribblings/framework/framework.scrbl | 9 ++ collects/scribblings/framework/splash.scrbl | 126 ++++++++++++++++++ 3 files changed, 137 insertions(+), 2 deletions(-) create mode 100644 collects/scribblings/framework/splash.scrbl diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 0357046f..153d868b 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -14,7 +14,7 @@ shutdown-splash close-splash add-splash-icon - set-splash-progress-bar? + set-splash-progress-bar?! set-splash-char-observer set-splash-event-callback get-splash-event-callback @@ -86,7 +86,7 @@ (send (icon-bm icon) get-loaded-mask))) icons)) -(define (set-splash-progress-bar? b?) +(define (set-splash-progress-bar?! b?) (send gauge-panel change-children (λ (l) (if b? (list gauge) '())))) diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl index 01d2b005..912ebadb 100644 --- a/collects/scribblings/framework/framework.scrbl +++ b/collects/scribblings/framework/framework.scrbl @@ -78,6 +78,14 @@ The precise set of exported names is: @racket[preferences:set-un/marshall], and @racket[preferences:restore-defaults]. } + +@item{@bold{Splash Screen} + @racket[(require @#,racketmodname[framework/splash])] + + This library provides support for a splash screen. See + @racketmodname[framework/splash] for more. +} + @item{@bold{Decorated Editor Snip} @racket[(require framework/decorated-editor-snip)] @@ -123,6 +131,7 @@ their feedback and help. @include-section["preferences-text.scrbl"] @include-section["scheme.scrbl"] @include-section["text.scrbl"] +@include-section["splash.scrbl"] @include-section["test.scrbl"] @include-section["version.scrbl"] diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl new file mode 100644 index 00000000..d9b58b77 --- /dev/null +++ b/collects/scribblings/framework/splash.scrbl @@ -0,0 +1,126 @@ +#lang scribble/doc +@(require scribble/manual + (for-label racket/gui + racket/base)) +@title{Splash} +@defmodule[framework/splash] + +This module helps support applications with splash screens like the one in DrRacket. + +When this module is invoked, it sets the @racket[current-load] parameter to a procedure +that counts how many files are loaded (until @racket[shutdown-splash] is called) and uses +that number to control the gauge along the bottom of the splash screen. + +@defproc[(start-splash [draw-spec (or/c path-string? + (vector/c (or/c (-> (is-a?/c dc<%>) void?) + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)) + exact-nonnegative-integer? + exact-nonnegative-integer?))] + [splash-title string?] + [width-default exact-nonnegative-integer?]) + void?]{ + Starts a new splash screen. The splash screen is created in its own, new + @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace}. + The progress gauge at the bottom of the window advances as files are loaded + (monitored via the @racket[current-load] parameter). + + The @racket[draw-spec] determines what the splash window contains. + The @racket[splash-title] is used as the title of the window and the @racket[width-default] determines + how many progress steps the gauge in the the splash screen should + contain (if there is no preference saved for the splash screen width; see @racket[set-splash-width-preference-name]). + + If the @racket[draw-spec] is a @racket[path-string?], then the path is expected to be a file + that contains a bitmap that is drawn as the contents of the splash screen. If @racket[draw-spec] + is a vector, then the vector's first element is a procedure that is called to draw + the splash screen and the other two integers are the size of the splash screen, width followed by height. + If the procedure accepts only one argument, then it is called with a @racket[dc<%>] object where the + drawing should occur. If it accepts 5 arguments, it is called with the @racket[dc<%>], as well as + (in order) the current value of the gauge, the maximum value of the gauge, and the width and the height + of the area to draw. + + + + } +@defproc[(shutdown-splash) void?]{ + Stops the splash window's gauge from advancing. Call this after all of the files have been loaded. +} + +@defproc[(close-splash) void?]{ + Closes the splash window. Call @racket[shutdown-splash] first. You can leave some time between these two + if there is more initialization work to be done where you do not want to count loaded files. +} + +@defproc[(add-splash-icon [bmp (is-a?/c bitmap%)] [x exact-nonnegative-integer?] [y exact-nonnegative-integer?]) + void?]{ + Adds an icon to the splash screen. (DrRacket uses this function to show the tools as they are loaded.) +} + +@defproc[(get-splash-bitmap) (or/c #f (is-a?/c bitmap%))]{Returns the splash bitmap unless one has not been set.} +@defproc[(set-splash-bitmap [bmp (is-a?/c bitmap%)]) void?]{ + Sets the splash bitmap to @racket[bmp] and triggers a redrawing of the splash screen. Don't use this to set + the initial bitmap, use @racket[start-splash] instead. +} +@defproc[(get-splash-canvas) (is-a?/c canvas%)]{ + Returns the canvas where the splash screen bitmap is drawn (if there is a bitmap; see @racket[start-splash] for how the splash is drawn. +} +@defproc[(get-splash-eventspace) eventspace?]{ + Returns the splash screen's eventspace. +} +@defproc[(get-splash-paint-callback) + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)]{ + Returns the callback that is invoked when redrawing the splash screen. +} +@defproc[(set-splash-paint-callback + [cb + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)]) + void?]{ + Sets the callback that is invoked when redrawing the splash screen. See @racket[start-splash] for + what the arguments are. +} +@defproc[(set-splash-progress-bar?! [b boolean?]) void?]{ + Calling this procedure with @racket[#f] removes the progress bar from the splash screen. + Useful in conjunction with setting your own paint callback for the splash screen that measures + progress in its own way, during drawing. DrRacket uses this on King Kamehameha and Prince + Kuhio day. +} +@defproc[(set-splash-char-observer [obs (-> (is-a?/c key-event%) any)]) void?]{ + Sets a procedure that is called whenever a user types a key with the splash screen as the focus. +} +@defproc[(set-splash-event-callback [obj (-> (is-?/c mouse-event%) any)]) void?]{ + Sets a procedure that is called whenever a mouse event happens in the splash canvas. } +@defproc[(get-splash-event-callback) (-> (is-?/c mouse-event%) any)]{ + Returns the last procedure passed to @racket[set-splash-event-callback] or @racket[void], if + @racket[set-splash-event-callback] has not been called. +} +@defproc[(set-refresh-splash-on-gauge-change?! [proc (-> exact-nonnegative-integer? + exact-nonnegative-integer? + any)]) + void?]{ + Sets a procedure that is called each time the splash gauge changes. If the procedure returns a true value (i.e., not @racket[#f]), + then the splash screen is redrawn. The procedure is called with the current value of the gauge and the maximum value. + + The default function is @racket[(lambda (curr tot) #f)]. +} +@defproc[(get-splash-width) exact-nonnegative-integer?]{Returns the width of the splash drawing area / bitmap. See @racket[start-splash] for the details of the size and how things are drawn.} +@defproc[(get-splash-height) exact-nonnegative-integer?]{Returns the width of the splash drawing area / bitmap. See @racket[start-splash] for the details of the size and how things are drawn.} +@defproc[(refresh-splash) void?]{ + Triggers a refresh of the splash, handling the details of double buffering + and doing the drawing on the splash's + @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace's} + main thread. +} From bb17de3e20afdb9618e79dadbac5783375e2b076 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Sep 2010 13:21:45 -0500 Subject: [PATCH 024/462] adjusted the splash screen code so that the christmas day easter egg is optional (defaultly off) original commit: 44753bc690292b114d934416ff2a096efc44199f --- collects/framework/splash.rkt | 28 +++++++++++++-------- collects/scribblings/framework/splash.scrbl | 5 ++-- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 153d868b..5c7b3ba6 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -72,8 +72,8 @@ (splash-paint-callback dc)] [else (splash-paint-callback dc - (send gauge get-value) - (send gauge get-range) + (send (get-gauge) get-value) + (send (get-gauge) get-range) (get-splash-width) (get-splash-height))]) (for-each (λ (icon) @@ -88,7 +88,7 @@ (define (set-splash-progress-bar?! b?) (send gauge-panel change-children - (λ (l) (if b? (list gauge) '())))) + (λ (l) (if b? (list (get-gauge)) '())))) (define (splash-paint-callback dc) (if splash-bitmap @@ -107,10 +107,11 @@ (set! icons (cons (make-icon bm x y) icons)) (refresh-splash)) -(define (start-splash splash-draw-spec _splash-title width-default) +(define (start-splash splash-draw-spec _splash-title width-default #:allow-funny? [allow-funny? #f]) + (unless allow-funny? (set! funny? #f)) (set! splash-title _splash-title) (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) - (send gauge set-range splash-max-width) + (send (get-gauge) set-range splash-max-width) (send splash-tlw set-label splash-title) (let/ec k (define (no-splash) @@ -188,8 +189,8 @@ (define (splash-load-handler old-load f expected) (set! splash-current-width (+ splash-current-width 1)) (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width) - (when (or (not (member gauge (send gauge-panel get-children))) + (send (get-gauge) set-value splash-current-width) + (when (or (not (member (get-gauge) (send gauge-panel get-children))) ;; when the gauge is not visible, we'll redraw the canvas (refresh-splash-on-gauge-change? splash-current-width splash-max-width)) (refresh-splash))) @@ -303,10 +304,15 @@ (define panel (make-object vertical-pane% splash-tlw)) (define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)])) (define gauge-panel (make-object horizontal-pane% panel)) -(define gauge - (if funny? - (make-object funny-gauge% gauge-panel) - (make-object gauge% #f splash-max-width gauge-panel '(horizontal)))) +(define get-gauge + (let ([gauge #f]) + (λ () + (unless gauge + (set! gauge + (if funny? + (make-object funny-gauge% gauge-panel) + (make-object gauge% #f splash-max-width gauge-panel '(horizontal))))) + gauge))) (send panel stretchable-width #f) (send panel stretchable-height #f) (send gauge-panel set-alignment 'center 'top) diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index d9b58b77..f64cd23d 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -22,7 +22,8 @@ that number to control the gauge along the bottom of the splash screen. exact-nonnegative-integer? exact-nonnegative-integer?))] [splash-title string?] - [width-default exact-nonnegative-integer?]) + [width-default exact-nonnegative-integer?] + #:allow-funny? [allow-funny? #f]) void?]{ Starts a new splash screen. The splash screen is created in its own, new @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace}. @@ -43,7 +44,7 @@ that number to control the gauge along the bottom of the splash screen. (in order) the current value of the gauge, the maximum value of the gauge, and the width and the height of the area to draw. - + The @racket[allow-funny?] argument determines if a special gauge is used on Christmas day. } @defproc[(shutdown-splash) void?]{ From 42ef533a5a07bbd352460fe9548b0dec310bd206 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Sep 2010 14:27:35 -0500 Subject: [PATCH 025/462] duh original commit: 70ea262426018c54fac78fa47a3c4a5a065efae4 --- collects/scribblings/framework/splash.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index f64cd23d..75c98868 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -23,7 +23,7 @@ that number to control the gauge along the bottom of the splash screen. exact-nonnegative-integer?))] [splash-title string?] [width-default exact-nonnegative-integer?] - #:allow-funny? [allow-funny? #f]) + [#:allow-funny? allow-funny? boolean? #f]) void?]{ Starts a new splash screen. The splash screen is created in its own, new @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace}. From 158145178ffcd649c68368935533acae0444cfd6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Sep 2010 14:39:16 -0500 Subject: [PATCH 026/462] added a note about how the max width is remembered in the splash screen original commit: 4c35af2eef7fe95efe89a465e221443b1b653702 --- collects/scribblings/framework/splash.scrbl | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index 75c98868..3c15fe8a 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -33,7 +33,12 @@ that number to control the gauge along the bottom of the splash screen. The @racket[draw-spec] determines what the splash window contains. The @racket[splash-title] is used as the title of the window and the @racket[width-default] determines how many progress steps the gauge in the the splash screen should - contain (if there is no preference saved for the splash screen width; see @racket[set-splash-width-preference-name]). + contain if there is no preference saved for the splash screen width. + The splash library uses @racket[get-preference] and @racket[put-preferences] + to store preferences, using + @racketblock[(string->symbol (format "plt:~a-splash-max-width" splash-title))] + as the key for the preference. Each time the app starts up, the maximum width + is reset based on the number of files that were loaded that time. If the @racket[draw-spec] is a @racket[path-string?], then the path is expected to be a file that contains a bitmap that is drawn as the contents of the splash screen. If @racket[draw-spec] From 62f4b7e9d52402fb3d17392cf8847b94f9f0c88c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 2 Sep 2010 10:59:38 -0500 Subject: [PATCH 027/462] fixed a performance bug (avoids computing the rotation of a bitmap when it isnt actually rotated...) original commit: 09bd56081b68ddbcbc46201af5ee2f4855e5d7a5 --- collects/mrlib/image-core.rkt | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 73392117..6259dace 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -829,18 +829,23 @@ the mask bitmap and the original bitmap are all together in a single bytes! (do-rotate bitmap flipped?)]))))) (define (do-rotate bitmap flip?) - (let ([θ (degrees->radians (bitmap-angle bitmap))]) - (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) - (bitmap-rendered-mask bitmap))]) - (let-values ([(rotated-bytes rotated-w rotated-h) - (rotate-bytes bytes w h θ)]) - (let* ([flipped-bytes (if flip? - (flip-bytes rotated-bytes rotated-w rotated-h) - rotated-bytes)] - [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] - [mask (send bm get-loaded-mask)]) - (set-bitmap-rendered-bitmap! bitmap bm) - (set-bitmap-rendered-mask! bitmap mask)))))) + (cond + [(zero? (bitmap-angle bitmap)) + ;; don't rotate anything in this case. + (void)] + [else + (let ([θ (degrees->radians (bitmap-angle bitmap))]) + (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) + (bitmap-rendered-mask bitmap))]) + (let-values ([(rotated-bytes rotated-w rotated-h) + (rotate-bytes bytes w h θ)]) + (let* ([flipped-bytes (if flip? + (flip-bytes rotated-bytes rotated-w rotated-h) + rotated-bytes)] + [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] + [mask (send bm get-loaded-mask)]) + (set-bitmap-rendered-bitmap! bitmap bm) + (set-bitmap-rendered-mask! bitmap mask)))))])) (define (do-scale bitmap) (let* ([bdc (make-object bitmap-dc%)] From 33957b3b3ccccbe8f31192907392674f7b9ec96f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 2 Sep 2010 12:20:19 -0500 Subject: [PATCH 028/462] forgot the flip check (caught by the test suites) original commit: 7fead2875a4c4503344a06a688b83e40561f0d3b --- collects/mrlib/image-core.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 6259dace..1fb72cf4 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -830,7 +830,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (do-rotate bitmap flip?) (cond - [(zero? (bitmap-angle bitmap)) + [(and (not flip?) (zero? (bitmap-angle bitmap))) ;; don't rotate anything in this case. (void)] [else From 9937aefd117e4b6b0827bea2e4338c905120a4a1 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 3 Sep 2010 05:39:27 -0600 Subject: [PATCH 029/462] removed useless requires original commit: fff692309edd4752c82cf4adab4c45a930d525ef --- collects/unstable/gui/notify.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/unstable/gui/notify.rkt b/collects/unstable/gui/notify.rkt index 368ea8d4..ff6f01d6 100644 --- a/collects/unstable/gui/notify.rkt +++ b/collects/unstable/gui/notify.rkt @@ -2,7 +2,7 @@ ;; owner: ryanc (require racket/list racket/class - racket/gui + racket/gui/base "../private/notify.rkt") (provide (all-from-out "../private/notify.rkt") menu-option/notify-box From ad9a2a87218c45b713a38af52043e60d7129441a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 5 Sep 2010 12:12:25 -0500 Subject: [PATCH 030/462] added a pinhole property to images original commit: 5e01ac55373d2987410da7d95f26f42535cfae3b --- collects/mrlib/image-core.rkt | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 1fb72cf4..cfd7d042 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -91,7 +91,7 @@ has been moved out). ;; (make-image shape bb boolean) ;; NOTE: the shape field is mutated when normalized, as ;; is the normalized? field. -(define (make-image shape bb normalized?) (new image% [shape shape] [bb bb] [normalized? normalized?])) +(define (make-image shape bb normalized? [pinhole #f]) (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole])) (define (image-shape p) (send p get-shape)) (define (image-bb p) (send p get-bb)) (define (image-normalized? p) (send p get-normalized?)) @@ -231,7 +231,7 @@ has been moved out). (define image% (class* snip% (equal<%>) - (init-field shape bb normalized?) + (init-field shape bb normalized? pinhole) (define/public (equal-to? that eq-recur) (or (eq? this that) (let ([that @@ -314,7 +314,7 @@ has been moved out). (calc-scroll-step) (inexact->exact (ceiling (/ y scroll-step)))) - (define/override (copy) (make-image shape bb normalized?)) + (define/override (copy) (make-image shape bb normalized? pinhole)) (define/override (draw dc x y left top right bottom dx dy draw-caret?) (let ([smoothing (send dc get-smoothing)]) (render-image this dc x y))) @@ -331,7 +331,7 @@ has been moved out). (set-box/f! rspace 0))) (define/override (write f) - (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb)))]) + (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))]) (send f put (bytes-length bytes) bytes))) (super-new) @@ -360,13 +360,22 @@ has been moved out). (racket/base:read (open-input-string str)))))]) - (if lst - (make-image (list-ref lst 0) - (list-ref lst 1) - #f) - (make-image (make-ellipse 100 100 0 'solid "black") - (make-bb 100 100 100) - #f)))) + (cond + [(not lst) + (make-image (make-ellipse 100 100 0 'solid "black") + (make-bb 100 100 100) + #f + #f)] + [(= 2 (length lst)) + (make-image (list-ref lst 0) + (list-ref lst 1) + #f + #f)] + [else + (make-image (list-ref lst 0) + (list-ref lst 1) + #f + (list-ref lst 2))]))) (super-new))) (provide snip-class) From 31af2360afcb73af035ce52fd3a1c6e68ffceec0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 5 Sep 2010 13:05:56 -0500 Subject: [PATCH 031/462] added pinhole drawing original commit: 748fc32bd1e0b3d99315fb69f3cfa810585f60f6 --- collects/mrlib/image-core.rkt | 43 +++++++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 7 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index cfd7d042..ea070810 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -88,7 +88,7 @@ has been moved out). ;; a image is -;; (make-image shape bb boolean) +;; (make-image shape bb boolean (or/c point #f)) ;; NOTE: the shape field is mutated when normalized, as ;; is the normalized? field. (define (make-image shape bb normalized? [pinhole #f]) (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole])) @@ -97,6 +97,10 @@ has been moved out). (define (image-normalized? p) (send p get-normalized?)) (define (set-image-shape! p s) (send p set-shape s)) (define (set-image-normalized?! p n?) (send p set-normalized? n?)) +(define (pinhole-x p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-x ph)))) +(define (pinhole-y p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-y ph)))) +(define (put-pinhole x y image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x y))) +(define (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) (define (image? p) (or (is-a? p image%) (is-a? p image-snip%) @@ -224,7 +228,7 @@ has been moved out). ; ;;;; (define-local-member-name - get-shape set-shape get-bb + get-shape set-shape get-bb get-pinhole get-normalized? set-normalized get-normalized-shape) (define skip-image-equality-fast-path (make-parameter #f)) @@ -274,6 +278,7 @@ has been moved out). (define/public (get-shape) shape) (define/public (set-shape s) (set! shape s)) (define/public (get-bb) bb) + (define/public (get-pinhole) pinhole) (define/public (get-normalized?) normalized?) (define/public (set-normalized? n?) (set! normalized? n?)) @@ -603,19 +608,38 @@ has been moved out). [brush (send dc get-brush)] [font (send dc get-font)] [fg (send dc get-text-foreground)] - [smoothing (send dc get-smoothing)]) + [smoothing (send dc get-smoothing)] + [alpha (send dc get-alpha)]) (cond [(is-a? image bitmap%) (send dc draw-bitmap image dx dy)] [(is-a? image image-snip%) (send dc draw-bitmap (send image get-bitmap) dx dy)] [else - (render-normalized-shape (send image get-normalized-shape) dc dx dy)]) + (render-normalized-shape (send image get-normalized-shape) dc dx dy) + (let ([ph (send image get-pinhole)]) + (when ph + (let* ([px (point-x ph)] + [py (point-y ph)] + [bb (image-bb image)] + [w (bb-right bb)] + [h (bb-bottom bb)]) + (send dc set-alpha (* alpha .5)) + (send dc set-smoothing 'smoothed) + + (send dc set-pen "white" 1 'solid) + (send dc draw-line (+ dx px .5) (+ dy .5) (+ dx px .5) (+ dy h -.5)) + (send dc draw-line (+ dx .5) (+ dy py .5) (+ dx w -.5) (+ dy py .5)) + + (send dc set-pen "black" 1 'solid) + (send dc draw-line (+ dx px -.5) (+ dy .5) (+ dx px -.5) (+ dy h -.5)) + (send dc draw-line (+ dx .5) (+ dy py -.5) (+ dx w -.5) (+ dy py -.5)))))]) (send dc set-pen pen) (send dc set-brush brush) (send dc set-font font) (send dc set-text-foreground fg) - (send dc set-smoothing smoothing))) + (send dc set-smoothing smoothing) + (send dc set-alpha alpha))) (define (save-image-as-bitmap image filename kind) (let* ([bb (send image get-bb)] @@ -1071,9 +1095,14 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image) + image-snip->image + + put-pinhole + clear-pinhole + pinhole-x + pinhole-y) ;; method names -(provide get-shape get-bb get-normalized? get-normalized-shape) +(provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?) From 4d26bbc40acacfe40ee84fa9242d0d00ae52810b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Sep 2010 06:12:45 -0500 Subject: [PATCH 032/462] Added docs and exported basic pinhole manipulation primitives original commit: 4fa7fa299490cf1cb7acf71ec4797a9a714c8e14 --- collects/mrlib/image-core.rkt | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index ea070810..d1a6fac8 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -97,10 +97,6 @@ has been moved out). (define (image-normalized? p) (send p get-normalized?)) (define (set-image-shape! p s) (send p set-shape s)) (define (set-image-normalized?! p n?) (send p set-normalized? n?)) -(define (pinhole-x p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-x ph)))) -(define (pinhole-y p) (let ([ph (send p get-pinhole)]) (and ph (pinhole-y ph)))) -(define (put-pinhole x y image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x y))) -(define (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) (define (image? p) (or (is-a? p image%) (is-a? p image-snip%) @@ -372,6 +368,7 @@ has been moved out). #f #f)] [(= 2 (length lst)) + ;; backwards compatibility for saved images that didn't have a pinhole (make-image (list-ref lst 0) (list-ref lst 1) #f @@ -1095,12 +1092,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image - - put-pinhole - clear-pinhole - pinhole-x - pinhole-y) + image-snip->image) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) From 973ed0288769c6c73ed25045aa180f74fa49f298 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Sep 2010 06:24:44 -0500 Subject: [PATCH 033/462] made scaling work with pinholes original commit: e3b51e8cf4da6fb1308d967129421386efeab4bc --- collects/mrlib/image-core.rkt | 5 ----- 1 file changed, 5 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index d1a6fac8..9bcf1ba7 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1,10 +1,5 @@ #lang racket/base -;; changed: -;; - simple-shape -;; - np-atomic-shape -;; - atomic-shape - #| This library is the part of the 2htdp/image From 189edf768688e62baca9593255e0439da02e8030 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Sep 2010 07:17:09 -0500 Subject: [PATCH 034/462] made equality check on images sensitive to pinholes original commit: d2e443ac97bfea7806f5709ba40c3b0b4ba77f10 --- collects/mrlib/image-core.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9bcf1ba7..e8bac3ff 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -236,6 +236,7 @@ has been moved out). [else that])]) (and (is-a? that image%) (same-bb? bb (send that get-bb)) + (equal? pinhole (send that get-pinhole)) (or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective (equal? (get-normalized-shape) (send that get-normalized-shape))) (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box From a155727e094d44a7c2e4e9287db7298cf49c3930 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 9 Sep 2010 14:16:56 -0500 Subject: [PATCH 035/462] changed the ->d contracts to ->i contracts original commit: d419e8c12a554d660a65198dd102bc03e01c93a8 --- collects/framework/gui-utils.rkt | 30 +++++++++++++++++------------- collects/framework/main.rkt | 16 ++++++++-------- collects/mrlib/name-message.rkt | 28 ++++++++++++++-------------- 3 files changed, 39 insertions(+), 35 deletions(-) diff --git a/collects/framework/gui-utils.rkt b/collects/framework/gui-utils.rkt index c50be8fb..7c89d95c 100644 --- a/collects/framework/gui-utils.rkt +++ b/collects/framework/gui-utils.rkt @@ -294,34 +294,38 @@ (provide/doc (proc-doc gui-utils:trim-string - (->d ([str string?][size (and/c number? positive?)]) + (->i ([str string?] + [size (and/c number? positive?)]) () - [_ (and/c string? - (λ (str) - ((string-length str) . <= . size)))]) + [res (size) + (and/c string? + (λ (str) + ((string-length str) . <= . size)))]) @{Constructs a string whose size is less than @scheme[size] by trimming the @scheme[str] and inserting an ellispses into it.}) (proc-doc gui-utils:quote-literal-label - (->d ([str string?]) + (->i ([str string?]) () - [_ (and/c string? - (lambda (str) - ((string-length str) . <= . 200)))]) + [res (str) + (and/c string? + (lambda (str) + ((string-length str) . <= . 200)))]) @{Constructs a string whose ampersand characters are escaped; the label is also trimmed to <= 200 characters.}) (proc-doc gui-utils:format-literal-label - (->d ([str string?]) + (->i ([str string?]) () - #:rest rest (listof any/c) - [_ (and/c string? - (lambda (str) - ((string-length str) . <= . 200)))]) + #:rest [rest (listof any/c)] + [res (str) + (and/c string? + (lambda (str) + ((string-length str) . <= . 200)))]) @{Formats a string whose ampersand characters are mk-escaped; the label is also trimmed to <= 200 mk-characters.}) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 71a01f89..e7d90cb3 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -195,15 +195,15 @@ (proc-doc/names preferences:add-panel (-> (or/c string? (cons/c string? (listof string?))) - (->d ([parent (is-a?/c area-container-window<%>)]) + (->i ([parent (is-a?/c area-container-window<%>)]) () - [_ - (let ([old-children (send parent get-children)]) - (and/c (is-a?/c area-container-window<%>) - (λ (child) - (andmap eq? - (append old-children (list child)) - (send parent get-children)))))]) + [_ (parent) + (let ([old-children (send parent get-children)]) + (and/c (is-a?/c area-container-window<%>) + (λ (child) + (andmap eq? + (append old-children (list child)) + (send parent get-children)))))]) void?) (labels f) @{@scheme[preferences:add-preference-panel] adds the result of @scheme[f] diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index d1ad4ccf..cdb5fbdb 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -1,11 +1,23 @@ #lang racket/gui +(define (get-left-side-padding) (+ button-label-inset circle-spacer)) +(define button-label-inset 1) +(define black-color (make-object color% "BLACK")) + +(define triangle-width 10) +(define triangle-height 14) +(define triangle-color (make-object color% 50 50 50)) + +(define border-inset 1) +(define circle-spacer 4) +(define rrect-spacer 3) + (provide/contract [get-left-side-padding (-> number?)] [pad-xywh (-> number? number? (>=/c 0) (>=/c 0) (values number? number? (>=/c 0) (>=/c 0)))] [draw-button-label - (->d ([dc (is-a?/c dc<%>)] + (->i ([dc (is-a?/c dc<%>)] [label (or/c false/c string?)] [x number?] [y number?] @@ -15,7 +27,7 @@ [grabbed? boolean?] [button-label-font (is-a?/c font%)] [bkg-color (or/c false/c (is-a?/c color%) string?)]) - #:pre-cond + #:pre (w h) (w . > . (- h (* 2 border-inset))) [result void?])] @@ -214,18 +226,6 @@ (stretchable-height #f) (send (get-dc) set-smoothing 'aligned))) -(define (get-left-side-padding) (+ button-label-inset circle-spacer)) -(define button-label-inset 1) -(define black-color (make-object color% "BLACK")) - -(define triangle-width 10) -(define triangle-height 14) -(define triangle-color (make-object color% 50 50 50)) - -(define border-inset 1) -(define circle-spacer 4) -(define rrect-spacer 3) - (define (offset-color color offset-one) (make-object color% (offset-one (send color red)) From b808f9045d2ee815b30f0defaff4526f05662004 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 13 Sep 2010 10:29:03 -0600 Subject: [PATCH 036/462] Adding PLAI keywords to default indent original commit: 12fb39f5bd473af62dd9d1ae03a066f047ea11fd --- collects/framework/private/main.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index b70d6f85..ab94bf35 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -208,7 +208,10 @@ (let ([hash-table (make-hasheq)]) (for-each (λ (x) (hash-set! hash-table x 'define)) - '(struct local)) + '(struct + local + + define-type)) (for-each (λ (x) (hash-set! hash-table x 'begin)) '(case-lambda @@ -264,6 +267,8 @@ with-output-to-file with-output-to-port for-all + + type-case )) (preferences:set-default 'framework:tabify From a717919298c572048734d4f6fc15cf96b9fe7d85 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 13 Sep 2010 16:40:21 -0500 Subject: [PATCH 037/462] closes PR 11207 original commit: 5b54caebb066920e2585244a5ee444a3f121c966 --- collects/framework/private/scheme.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index 07e72d92..5d46dc65 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -204,7 +204,8 @@ (let ([up-sexp (send text find-up-sexp click-pos)]) (when up-sexp (let ([fwd (send text get-forward-sexp up-sexp)]) - (make-collapse-item text up-sexp fwd menu))))])))) + (when fwd + (make-collapse-item text up-sexp fwd menu)))))])))) ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void (define (make-expand-item text snip menu) From 4e3ac8b77f86fc213158f8543050f67c2124beea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Sep 2010 19:51:40 -0600 Subject: [PATCH 038/462] fix documented canvas-scroll limits original commit: fd285baeac57bcb60037b6777e2fd0e72aaa4423 --- collects/scribblings/gui/canvas-class.scrbl | 28 ++++++++++----------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 16ee2c7c..e5dee91e 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -91,7 +91,7 @@ The @scheme[gl-config] argument determines properties of an OpenGL } @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) - (integer-in 1 1000000000)]{ + (integer-in 1 10000)]{ Get the current page step size of a manual scrollbar. The result is @scheme[0] if the scrollbar is not active or it is automatic. @@ -106,7 +106,7 @@ See also @defmethod[(get-scroll-pos [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 1000000000)]{ + (integer-in 0 10000)]{ Gets the current value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -121,7 +121,7 @@ See also @defmethod[(get-scroll-range [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 1000000000)]{ + (integer-in 0 10000)]{ Gets the current maximum value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -163,8 +163,8 @@ Gets the size in device units of the scrollable canvas area (as } -@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000000) false/c)] - [vert-pixels (or/c (integer-in 1 1000000000) false/c)] +@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 10000) false/c)] + [vert-pixels (or/c (integer-in 1 10000) false/c)] [h-value (real-in 0.0 1.0)] [v-value (real-in 0.0 1.0)]) void?]{ @@ -202,12 +202,12 @@ See also } -@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000000) false/c)] - [v-length (or/c (integer-in 0 1000000000) false/c)] - [h-page (integer-in 1 1000000000)] - [v-page (integer-in 1 1000000000)] - [h-value (integer-in 0 1000000000)] - [v-value (integer-in 0 1000000000)]) +@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 10000) false/c)] + [v-length (or/c (integer-in 0 10000) false/c)] + [h-page (integer-in 1 10000)] + [v-page (integer-in 1 10000)] + [h-value (integer-in 0 10000)] + [v-value (integer-in 0 10000)]) void?]{ Enables and initializes manual scrollbars for the canvas. A @@ -299,7 +299,7 @@ See also @defmethod[(set-scroll-page [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 1 1000000000)]) + [value (integer-in 1 10000)]) void?]{ Set the current page step size of a manual scrollbar. (This method has @@ -316,7 +316,7 @@ See also @defmethod[(set-scroll-pos [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 1000000000)]) + [value (integer-in 0 10000)]) void?]{ Sets the current value of a manual scrollbar. (This method has no @@ -336,7 +336,7 @@ See also @defmethod[(set-scroll-range [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 1000000000)]) + [value (integer-in 0 10000)]) void?]{ Sets the current maximum value of a manual scrollbar. (This method has From 4155ffbbeb56f317333fbb94d4df1560fac23446 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 19:17:58 -0600 Subject: [PATCH 039/462] extend `invalidate-bitmap-cache' in `editor<%>' with 'display-end option which the framework's background-rectangle implementation can use to queue refreshes for changing rectangles, instead of requiring a full-canvas refresh original commit: aac7e0b58a2dd7a5e964785b0162ab48c9081c8f --- collects/framework/private/text.rkt | 131 ++++++--------------- collects/mred/private/wxme/pasteboard.rkt | 73 ++++++------ collects/mred/private/wxme/text.rkt | 38 +++--- collects/scribblings/gui/editor-intf.scrbl | 12 +- 4 files changed, 105 insertions(+), 149 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9fd0cbc9..72d5bbb1 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -144,98 +144,45 @@ WARNING: printf is rebound in the body of the unit to always (send (get-style-list) find-named-style "Standard")) (define/private (invalidate-rectangles rectangles) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [canvases (get-canvases)]) - (let-values ([(min-left max-right) - (cond - [(null? canvases) - (let ([admin (get-admin)]) - (if admin - (begin - (send admin get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))) - (values #f #f)))] - [else - (let loop ([left #f] - [right #f] - [canvases canvases]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (λ () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if (and left right) - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))])]) - (when (and min-left max-right) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles] - [refresh? #f]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when refresh? - (for-each (λ (canvas) (send canvas refresh)) - canvases)) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [adjust (λ (w f) - (+ w (f (case (rectangle-style r) - [(dot hollow-ellipse) 8] - [else 0]))))] - [this-left (if (number? (rectangle-left r)) - (adjust (rectangle-left r) -) - min-left)] - [this-right (if (number? (rectangle-right r)) - (adjust (rectangle-right r) +) - max-right)] - [this-top (adjust (rectangle-top r) -)] - [this-bottom (adjust (rectangle-bottom r) +)]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r))))) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r)))))))])))))) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (if (number? right) (- right left) 'display-end)] + [height (if (number? bottom) (- bottom top) 'display-end)]) + (when (and (or (symbol? width) (> width 0)) + (or (symbol? height) (> height 0))) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + [adjust (λ (w f) + (+ w (f (case (rectangle-style r) + [(dot hollow-ellipse) 8] + [else 0]))))] + [this-left (if (number? (rectangle-left r)) + (adjust (rectangle-left r) -) + 0.0)] + [this-right (if (number? (rectangle-right r)) + (adjust (rectangle-right r) +) + 'display-end)] + [this-top (adjust (rectangle-top r) -)] + [this-bottom (adjust (rectangle-bottom r) +)]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (if (and (number? this-right) (number? right)) + (max this-right right) + 'display-end) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))]))) (define/private (recompute-range-rectangles) (let* ([b1 (box 0)] diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4c07fd66..0d9a76bf 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -137,8 +137,10 @@ (define update-left 0.0) (define update-right 0.0) + (define update-right-end #f) (define update-top 0.0) (define update-bottom 0.0) + (define update-bottom-end #f) (define update-nonempty? #f) (define no-implicit-update? #f) @@ -1409,8 +1411,8 @@ delayedscroll-x delayedscroll-y delayedscroll-w delayedscroll-h #t delayedscrollbias))) - (let ([r (+ x w)] - [b (+ y h)]) + (let ([r (if (symbol? w) x (+ x w))] + [b (if (symbol? h) y (+ y h))]) (let ([x (max x 0.0)] [y (max y 0.0)] [r (max r 0.0)] @@ -1422,51 +1424,42 @@ (begin (set! update-top y) (set! update-left x) - (set! update-bottom (if (h . < . 0) h b)) - (set! update-right (if (w . < . 0) w r)) + (set! update-bottom b) + (set! update-bottom-end (and (symbol? h) h)) + (set! update-right r) + (set! update-right-end (and (symbol? w) w)) (set! update-nonempty? #t)) (begin (set! update-top (min y update-top)) (set! update-left (min x update-left)) - (let ([ub (if (and (h . < . 0) (update-bottom . > . 0)) - (- update-bottom) - update-bottom)]) - (set! update-bottom - (if (ub . < . 0) - (if (and (h . < . 0) (h . < . ub)) - h - (if (and (h . > . 0) - ((- b) . < . ub)) - (- b) - ub)) - (max b ub)))) - (let ([ur (if (and (w . < . 0) (update-right . > . 0)) - (- update-right) - update-right)]) - (set! update-right - (if (ur . < . 0) - (if (and (w . < . 0) (w . < . ur)) - w - (if (and (w . > . 0) - ((- r) . < . ur)) - (- r) - ur)) - (max r ur)))))) + (set! update-bottom (max b update-bottom)) + (when (symbol? b) + (if (eq? b 'display-end) + (set! update-bottom-end 'display-end) + (unless (eq? update-bottom-end 'display-end) + (set! update-bottom-end 'end)))) + (set! update-right (max r update-right)) + (when (symbol? r) + (if (eq? r 'display-end) + (set! update-right-end 'display-end) + (unless (eq? update-right-end 'display-end) + (set! update-right-end 'end)))))) (unless (or (positive? sequence) (not s-admin) flow-locked?) (check-recalc) - (when (update-bottom . < . 0) - (set! update-bottom (- update-bottom)) - (when (update-bottom . < . real-height) - (set! update-bottom real-height))) - - (when (update-right . < . 0) - (set! update-right (- update-right)) - (when (update-right . < . real-width) - (set! update-right real-width))) + (let-boxes ([vx 0.0] [vy 0.0] [vw 0.0] [vh 0.0]) + (when (or (eq? update-bottom-end 'display-end) + (eq? update-right-end 'display-end)) + (send s-admin get-max-view x y w h)) + (case update-bottom-end + [(end) (set! update-bottom (max update-bottom real-height))] + [(display-end) (set! update-bottom (max update-bottom vh))]) + (case update-right-end + [(end) (set! update-right (max update-right real-width))] + [(display-end) (set! update-right (max update-right vw))])) (set! update-nonempty? #f) @@ -1520,9 +1513,9 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (update x y (if (symbol? w) -1.0 w) (if (symbol? h) -1.0 h))) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (update x y w h)) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index f932224d..978bb8a3 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -277,8 +277,8 @@ (define refresh-end 0) (define refresh-l 0.0) (define refresh-t 0.0) - (define refresh-r 0.0) - (define refresh-b 0.0) + (define refresh-r 0.0) ; can be 'display-end + (define refresh-b 0.0) ; can be 'display-end (define last-draw-l 0.0) (define last-draw-t 0.0) @@ -3908,8 +3908,8 @@ #t)))) (define/public (refresh-box L T w h) - (let ([B (+ T h)] - [R (+ L w)]) + (let ([B (if (eq? h 'display-end) h (+ T h))] + [R (if (eq? w 'display-end) w (+ L w))]) (if refresh-box-unset? (begin (set! refresh-l L) @@ -3920,11 +3920,13 @@ (begin (when (L . < . refresh-l) (set! refresh-l L)) - (when (R . > . refresh-r) + (when (or (eq? R 'display-end) + (R . > . refresh-r)) (set! refresh-r R)) (when (T . < . refresh-t) (set! refresh-t T)) - (when (B . > . refresh-b) + (when (or (eq? B 'display-end) + (B . > . refresh-b)) (set! refresh-b B)))) (set! draw-cached-in-bitmap? #f))) @@ -3943,10 +3945,10 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (let ([w (if (symbol? w) (- total-width x) w)] - [h (if (symbol? h) (- total-height y) h)]) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (let ([w (if (eq? w 'end) (- total-width x) w)] + [h (if (eq? h 'end) (- total-height y) h)]) (refresh-box x y w h) (when (zero? delay-refresh) @@ -4809,9 +4811,13 @@ (values left right top bottom) (values (max refresh-l left) - (min refresh-r right) + (if (eq? refresh-r 'display-end) + right + (min refresh-r right)) (max refresh-t top) - (min refresh-b bottom)))]) + (if (eq? refresh-b 'display-end) + bottom + (min refresh-b bottom))))]) (set! refresh-unset? #t) (set! refresh-box-unset? #t) (set! refresh-all? #f) @@ -4884,8 +4890,12 @@ #t)) (values (max refresh-l left) (max top refresh-t) - (min right refresh-r) - (min bottom refresh-b) + (if (eq? refresh-r 'display-end) + right + (min right refresh-r)) + (if (eq? refresh-b 'display-end) + bottom + (min bottom refresh-b)) #t)) (values left top right bottom refresh-all?))]) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 5134b7e2..cf630721 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1006,8 +1006,8 @@ See also @method[editor<%> insert-file]. @defmethod[(invalidate-bitmap-cache [x real? 0.0] [y real? 0.0] - [width (or/c (and/c real? (not/c negative?)) 'end) 'end] - [height (or/c (and/c real? (not/c negative?)) 'end) 'end]) + [width (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end] + [height (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end]) void?]{ When @method[editor<%> on-paint] is overridden, call this method when @@ -1018,7 +1018,13 @@ The @scheme[x], @scheme[y], @scheme[width], and @scheme[height] coordinates. If @scheme[width]/@scheme[height] is @scheme['end], then the total height/width of the editor (as reported by @method[editor<%> get-extent]) is used. Note that the editor's size - can be smaller than the visible region of its @techlink{display}. + can be smaller than the visible region of its @techlink{display}. If + @scheme[width]/@scheme[height] is @scheme['display-end], then the + largest height/width of the editor's views (as reported by + @method[editor-admin% get-max-view]) is used. If + @scheme[width]/@scheme[height] is not @scheme['display-end], then + the given @scheme[width]/@scheme[height] is constrained to the + editor's size. The default implementation triggers a redraw of the editor, either immediately or at the end of the current edit sequence (if any) From deac00ebf4978fbd7c006c8aa4c5bf4e1f9c19e2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Sep 2010 12:29:11 -0600 Subject: [PATCH 040/462] fix bug introduced with 'display-end change original commit: f67bb10c19cf3557bb19275a0a2e5bcd1d47d43a --- collects/mred/private/wxme/text.rkt | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 978bb8a3..5e5a4d95 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -3920,15 +3920,17 @@ (begin (when (L . < . refresh-l) (set! refresh-l L)) - (when (or (eq? R 'display-end) - (R . > . refresh-r)) - (set! refresh-r R)) + (unless (eq? refresh-r 'display-end) + (when (or (eq? R 'display-end) + (R . > . refresh-r)) + (set! refresh-r R))) (when (T . < . refresh-t) (set! refresh-t T)) - (when (or (eq? B 'display-end) - (B . > . refresh-b)) - (set! refresh-b B)))) - + (unless (eq? refresh-b 'display-end) + (when (or (eq? B 'display-end) + (B . > . refresh-b)) + (set! refresh-b B))))) + (set! draw-cached-in-bitmap? #f))) (def/override (needs-update [snip% snip] From 7ce956664db2508df66215aa94f413d7f25d8c84 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Sep 2010 03:55:30 -0400 Subject: [PATCH 041/462] Some repeated "and and"s and "the the"s, and two more typos. Closes PR 11229. original commit: ee138cf2cba3ee32cd755a7b242ec10051180adf --- collects/scribblings/framework/splash.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index 3c15fe8a..e9dc3328 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -32,7 +32,7 @@ that number to control the gauge along the bottom of the splash screen. The @racket[draw-spec] determines what the splash window contains. The @racket[splash-title] is used as the title of the window and the @racket[width-default] determines - how many progress steps the gauge in the the splash screen should + how many progress steps the gauge in the splash screen should contain if there is no preference saved for the splash screen width. The splash library uses @racket[get-preference] and @racket[put-preferences] to store preferences, using From 7a1c34c546d2bf4c59f2b31066cff657e00b0640 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 Sep 2010 16:47:55 -0500 Subject: [PATCH 042/462] closes PR 11236 original commit: 08b9396e2fdea6e1430cfabc130efafe14a5c4b1 --- collects/mrlib/image-core.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index e8bac3ff..6c15ac3a 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -774,12 +774,12 @@ has been moved out). (define (polygon-points->path points) (let ([path (new dc-path%)]) - (send path move-to (round (point-x (car points))) (round (point-y (car points)))) + (send path move-to (point-x (car points)) (point-y (car points))) (let loop ([points (cdr points)]) (unless (null? points) (send path line-to - (round (point-x (car points))) - (round (point-y (car points)))) + (point-x (car points)) + (point-y (car points))) (loop (cdr points)))) (send path close) ;(send path line-to (round (point-x (car points))) (round (point-y (car points)))) From b343e68e2e6107ae2663b0cbde6b1e00360b599f Mon Sep 17 00:00:00 2001 From: John Clements Date: Sat, 2 Oct 2010 09:45:25 -0700 Subject: [PATCH 043/462] it's -> its original commit: e94163f37a218390e64174d5db89ba27210e1a87 --- collects/scribblings/gui/editor-canvas-class.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index 9a25dc9c..f0bf8589 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -71,7 +71,7 @@ The @scheme[style] list can contain the following flags: method} @item{@scheme['transparent] --- the canvas is ``erased'' before an - update using it's parent window's background} + update using its parent window's background} ] From 872c5872555d372b4320b6f4be503acb7053df56 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 7 Oct 2010 19:35:53 -0500 Subject: [PATCH 044/462] closes PR 11293 original commit: 05d16d931121f56a2b98454d61d17588635cbadc --- collects/mrlib/image-core.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 6c15ac3a..5088b252 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -905,10 +905,11 @@ the mask bitmap and the original bitmap are all together in a single bytes! (set-bitmap-rendered-mask! bitmap new-mask))) (define (text->font text) + (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) (cond [(text-face text) (send the-font-list find-or-create-font - (text-size text) + adjusted-size (text-face text) (text-family text) (text-style text) @@ -916,7 +917,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (text-underline text))] [else (send the-font-list find-or-create-font - (text-size text) + adjusted-size (text-family text) (text-style text) (text-weight text) From 7f2097e2bb5a3fb79da05888ceb625637b1d5b52 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 11 Oct 2010 16:00:03 -0500 Subject: [PATCH 045/462] added an argument to open-input-text-editor so that it can lock (and unlock) the editor when editing would not be allowed. original commit: 3e9858b001699d9ef66d016a2ee691dacc5a8503 --- collects/mred/private/snipfile.rkt | 59 +++++++++++++-------- collects/scribblings/gui/editor-funcs.scrbl | 8 ++- collects/tests/gracket/editor.rktl | 27 +++++++++- 3 files changed, 68 insertions(+), 26 deletions(-) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index bd8ba41f..9da20e4c 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -1,11 +1,10 @@ -(module snipfile mzscheme - (require mzlib/class - mzlib/etc - mzlib/port +(module snipfile racket/base + (require racket/class + racket/port syntax/moddep - (prefix wx: "kernel.ss") - (prefix wx: "wxme/snip.ss") - (prefix wx: "wxme/cycle.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/cycle.ss") "check.ss" "editor.ss") @@ -72,7 +71,8 @@ ;; starting at position `start-in' ;; and ending at position `end'. (define open-input-text-editor - (opt-lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f]) + (lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f] + #:lock-while-reading? [lock-while-reading? #f]) ;; Check arguments: (unless (text . is-a? . text%) (raise-type-error 'open-input-text-editor "text% object" text)) @@ -105,24 +105,33 @@ ;; 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]) - (let-values ([(pipe-r pipe-w) (make-pipe)]) + (let ([start start]) + (when lock-while-reading? (send text lock #t)) + (let-values ([(pipe-r pipe-w) (make-pipe)]) (make-input-port/read-to-peek - port-name + 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 - (close-output-port pipe-w) - eof) + (close-output-port pipe-w) + (when lock-while-reading? + (set! lock-while-reading? #f) + (send text lock #f)) + eof) (begin (write-string (send text get-text start (+ start n)) pipe-w) (set! start (+ start n)) - (read-bytes-avail!* s pipe-r)))) + (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))) + ans)))) v))) - (lambda (s skip general-peek) + (lambda (s skip general-peek) (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) (if (eq? v 0) (general-peek s skip) @@ -184,17 +193,21 @@ [port (make-input-port/read-to-peek port-name (lambda (s) - (let ([v (read-bytes-avail!* s pipe-r)]) - (if (eq? v 0) - (read-chars s) - v))) - (lambda (s skip general-peek) + (let* ([v (read-bytes-avail!* s pipe-r)] + [res (if (eq? v 0) (read-chars s) v)]) + (when (eof-object? res) + (when lock-while-reading? + (set! lock-while-reading? #f) + (send text lock #f))) + 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)]) - (if (is-a? snip wx:string-snip%) + (when lock-while-reading? (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)] @@ -235,7 +248,7 @@ (apply values last-time-values) (call-with-values (lambda () (call-with-continuation-prompt (lambda () (eval - (datum->syntax-object + (datum->syntax #f (cons '#%top-interaction exp) exp))) @@ -271,7 +284,7 @@ p)) (define open-output-text-editor - (opt-lambda (text [start 'end] [special-filter values] [port-name text]) + (lambda (text [start 'end] [special-filter values] [port-name text]) (define pos (if (eq? start 'end) (send text last-position) (min start diff --git a/collects/scribblings/gui/editor-funcs.scrbl b/collects/scribblings/gui/editor-funcs.scrbl index d378d873..24dd7864 100644 --- a/collects/scribblings/gui/editor-funcs.scrbl +++ b/collects/scribblings/gui/editor-funcs.scrbl @@ -213,7 +213,8 @@ Opens @racket[filename] (in @racket['binary] mode) and checks whether it looks [end-position (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [snip-filter ((is-a?/c snip%) . -> . any/c) (lambda (s) s)] [port-name any/c text-editor] - [expect-to-read-all? any/c #f]) + [expect-to-read-all? any/c #f] + [#:lock-while-reading? lock-while-reading? any/c #f]) input-port]{ Creates an input port that draws its content from @racket[text-editor]. @@ -252,7 +253,10 @@ The result port must not be used if @racket[text-editor] changes in any @method[snip-admin% recounted]). The @method[text% get-revision-number] method can be used to detect any of these changes. - +To help guard against such uses, if @racket[lock-while-reading?] argument is +a true value, then @racket[open-input-text-editor] will lock the @racket[text-editor] +before it returns and unlock it after it is safe to use the above methods. (In some +cases, it will not lock the editor at all, if using those methods are always safe.) } diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index a40b8ba9..7551cca2 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -259,7 +259,32 @@ (test 'hello 'read (read p)) (test 'there 'read (read p)) (test 'res 'read (read p)) - (test #t 'read (is-a? (read p) image-snip%)))) + (test #t 'read (is-a? (read p) image-snip%))) + + + (let () + (define t (new text%)) + (send t insert (make-string 5000 #\a)) + (define p (open-input-text-editor t #:lock-while-reading? #t)) + (define locked-first (send t is-locked?)) + (void (read p)) ;; read the (big) symbol + (void (read p)) ;; read eof + (define locked-last (send t is-locked?)) + (test #t 'lock-while-reading?1 (and locked-first (not locked-last)))) + + (let () + (define t (new text%)) + (send t insert (make-string 5000 #\a)) + (send t insert (make-object image-snip%)) + (define p (open-input-text-editor t #:lock-while-reading? #t)) + (define locked-first (send t is-locked?)) + (void (read p)) ;; read the (big) symbol + (void (read p)) ;; read the image + (void (read p)) ;; read eof + (define locked-last (send t is-locked?)) + (test #t 'lock-while-reading?2 + (and locked-first + (not locked-last))))) (let () (define x (new text%)) From 476d080852a8301fbb74c342655cd96dbfa97c97 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 Oct 2010 13:44:03 -0400 Subject: [PATCH 046/462] Encode any text instead of going through a pretty-printer. original commit: 42e76eaaf4a34dd439bc34d586144ab6127e7b72 --- collects/framework/private/bday.rkt | 62 +++++++++++++------------ collects/framework/private/decode.rkt | 6 +-- collects/framework/private/encode.rkt | 67 ++++++++++++--------------- 3 files changed, 64 insertions(+), 71 deletions(-) diff --git a/collects/framework/private/bday.rkt b/collects/framework/private/bday.rkt index 42dabb81..7f6e6890 100644 --- a/collects/framework/private/bday.rkt +++ b/collects/framework/private/bday.rkt @@ -1,32 +1,34 @@ #lang s-exp framework/private/decode - XY9BD - sIgEEWv - 8pfMgqRV - E3Whn - qXtT - GOjg - AE08 - fYWp - 62Nu - 897D - PMxjx - heAwtc - 7G3Lzfs - CN4 d0m - 4K0G giGp - R+8w JgC4 - MA0w rvkk - XCTR 5GkC - 56T Peux - e8Yo PtsJ - E5X7 jWeY - E74T 1gWf - ryiR 4OjH - y/tK Waem - 1XMZ aIU9 - ttXK LuXV - 1hU2 x7WO - f75G vdLLj - 9Xuc CD6A - \\\\ A== + TY+9Ds + IwDIT3P + MWN9hCJA + hIwAA + +CGN + rGFR + UkRW + lA4u + 1JaF + K6ne + /zz1n + R0w/v + 3gis73R + j6s8Zto + jxn oU0 + k2Cl yEjX + OwFR cmBh + mBVA Dwmg + i6lD RKO0 + gzOj Pk1l + +/Je XNDZ + Zr6m iThT + OwM6 glKb + toML NyTJ + sPz3 05XJ + jZd4 kaCE + iot+ UbDD + ZhUb Cp/f + yLxa YX1Y + 8vnh zCug + WvD5 +7J/C + +wj/ \wI=;; diff --git a/collects/framework/private/decode.rkt b/collects/framework/private/decode.rkt index 0944528e..6f21e079 100644 --- a/collects/framework/private/decode.rkt +++ b/collects/framework/private/decode.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require (for-syntax scheme/base file/gunzip net/base64)) -(provide (except-out (all-from-out scheme/base) #%module-begin) +#lang racket/base +(require (for-syntax racket/base file/gunzip net/base64)) +(provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [module-begin #%module-begin])) (define-syntax (module-begin stx) diff --git a/collects/framework/private/encode.rkt b/collects/framework/private/encode.rkt index 4e3c455c..31b876d4 100644 --- a/collects/framework/private/encode.rkt +++ b/collects/framework/private/encode.rkt @@ -1,43 +1,34 @@ -#lang scheme/base -(require scheme/cmdline scheme/string scheme/match scheme/pretty - file/gzip file/gunzip net/base64) +#lang racket/base +(require racket/cmdline racket/string file/gzip file/gunzip net/base64) -(define (encode-exprs exprs) - (define in - (open-input-string - (string-join (map (lambda (x) (format "~s" x)) exprs) " "))) - (define out (open-output-bytes)) - (deflate in out) - (base64-encode (get-output-bytes out))) +(define do-lang? #f) -(define (encode-module) - (define mod (parameterize ([read-accept-reader #t]) (read))) - (when (eof-object? mod) (error 'encode-module "missing module")) - (match mod - [(list 'module m 'scheme/base (list '#%module-begin exprs ...)) - (write-bytes #"#lang s-exp framework/private/decode\n") - (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))] - [else (error 'encode-module "cannot parse module, must use scheme/base")])) +(define (encode/decode-text who lang-from lang-to convert1 convert2) + (when do-lang? + (let ([l (cadr (or (regexp-match #rx"^ *#lang +(.*[^ ]) *$" (read-line)) + (error who "missing #lang line")))]) + (if (equal? l lang-from) + (printf "#lang ~a\n" lang-to) + (error who "bad #lang: expected ~s, got ~s" lang-from l)))) + (define O (open-output-bytes)) + (convert1 (current-input-port) O) + (convert2 (open-input-bytes (get-output-bytes O)) (current-output-port)) + (flush-output)) -(define (decode-module) - (define mod (parameterize ([read-accept-reader #t]) (read))) - (when (eof-object? mod) (error 'encode-module "missing module")) - (match mod - [(list 'module m 'framework/private/decode - (list '#%module-begin exprs ...)) - (write-bytes #"#lang scheme/base\n") - (let* ([data (format "~a" exprs)] - [data (substring data 1 (sub1 (string-length data)))] - [data (string->bytes/utf-8 data)] - [in (open-input-bytes (base64-decode data))] - [out (open-output-string)] - [out (begin (inflate in out) (get-output-string out))] - [exprs (read (open-input-string (string-append "(" out ")")))]) - (for ([expr (in-list exprs)]) - (pretty-print expr)))] - [else (error 'decode-module "cannot parse module, must use scheme/base")])) +(define (encode-text) + (encode/decode-text + 'encode-text "racket/base" "s-exp framework/private/decode" + deflate base64-encode-stream)) -(command-line #:once-any - ["-e" "encode" (encode-module) (exit)] - ["-d" "decode" (decode-module) (exit)]) +(define (decode-text) + (encode/decode-text + 'decode-text "s-exp framework/private/decode" "racket/base" + base64-decode-stream inflate)) + +(command-line + #:once-each + ["-l" "translate lang line" (set! do-lang? #t)] + #:once-any + ["-e" "encode" (encode-text) (exit)] + ["-d" "decode" (decode-text) (exit)]) (printf "Use `-h' for help\n") From 0cf93e975c792cb914eeb8f544517e9d99eac29a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 Oct 2010 14:04:22 -0500 Subject: [PATCH 047/462] added a check to avoid creating a new bitmap struct (so caching works better when you flip images that are not scaled) original commit: 1d0ebeae62bce8ec43dde86a772d62f587b4c7f1 --- collects/mrlib/image-core.rkt | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 5088b252..92d5a325 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -557,14 +557,18 @@ has been moved out). (text-weight shape) (text-underline shape))] [(flip? shape) - (let ([bitmap (flip-shape shape)]) - (make-flip (flip-flipped? shape) - (make-bitmap (bitmap-raw-bitmap bitmap) - (bitmap-raw-mask bitmap) - (bitmap-angle bitmap) - (* x-scale (bitmap-x-scale bitmap)) - (* y-scale (bitmap-y-scale bitmap)) - #f #f)))])) + (cond + [(and (= 1 x-scale) (= 1 y-scale)) + shape] + [else + (let ([bitmap (flip-shape shape)]) + (make-flip (flip-flipped? shape) + (make-bitmap (bitmap-raw-bitmap bitmap) + (bitmap-raw-mask bitmap) + (bitmap-angle bitmap) + (* x-scale (bitmap-x-scale bitmap)) + (* y-scale (bitmap-y-scale bitmap)) + #f #f)))])])) (define (scale-color color x-scale y-scale) (cond From 8fb67cd27d6387aa54e04c202a5ddb1b0f6c9ac6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 17 Oct 2010 10:24:06 -0500 Subject: [PATCH 048/462] adjusted the recently opened menu items code so that it does not create all of the menu items as often original commit: 0614da599255ebb5ebfc4879c42eb0a74aa0e1c1 --- collects/framework/private/handler.rkt | 48 ++++++++++++++++++-------- 1 file changed, 34 insertions(+), 14 deletions(-) diff --git a/collects/framework/private/handler.rkt b/collects/framework/private/handler.rkt index 04ddade5..3890f7eb 100644 --- a/collects/framework/private/handler.rkt +++ b/collects/framework/private/handler.rkt @@ -181,23 +181,43 @@ (let ([recently-opened-files (preferences:get 'framework:recently-opened-files/pos)]) - (for ([item (send menu get-items)]) (send item delete)) - - (for ([recent-list-item recently-opened-files]) - (let ([filename (car recent-list-item)]) + (unless (menu-items-still-same? recently-opened-files menu) + (for ([item (send menu get-items)]) (send item delete)) + + (for ([recent-list-item recently-opened-files]) (new menu-item% - [parent menu] - [label (gui-utils:trim-string - (regexp-replace* #rx"&" (path->string filename) "\\&\\&") - 200)] - [callback (λ (x y) (open-recent-list-item recent-list-item))]))) - (new separator-menu-item% [parent menu]) - (new menu-item% - [parent menu] - [label (string-constant show-recent-items-window-menu-item)] - [callback (λ (x y) (show-recent-items-window))]) + [parent menu] + [label (recent-list-item->menu-label recent-list-item)] + [callback (λ (x y) (open-recent-list-item recent-list-item))])) + (new separator-menu-item% [parent menu]) + (new menu-item% + [parent menu] + [label (string-constant show-recent-items-window-menu-item)] + [callback (λ (x y) (show-recent-items-window))])) (void))) +(define (recent-list-item->menu-label recent-list-item) + (let ([filename (car recent-list-item)]) + (gui-utils:trim-string + (regexp-replace* #rx"&" (path->string filename) "\\&\\&") + 200))) + +;; this function must mimic what happens in install-recent-items +;; it returns #t if all of the labels of menus are the same, or approximation to +;; the menus actually being different +(define (menu-items-still-same? recently-opened-files menu) + (let ([current-items + (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) + (send menu get-items))] + ;; the new-items variable shoudl match up to what install-recent-items actually does when it creates the menu + [new-items + (append + (for/list ([recent-list-item recently-opened-files]) + (recent-list-item->menu-label recent-list-item)) + (list #f + (string-constant show-recent-items-window-menu-item)))]) + (equal? current-items new-items))) + ;; open-recent-list-item : recent-list-item -> void (define (open-recent-list-item recent-list-item) (let* ([filename (car recent-list-item)] From 2270612ece5a26bd6a3ed6b210e78733f818a115 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 Oct 2010 17:40:26 -0500 Subject: [PATCH 049/462] adjusted the way caching works for bitmaps to be more effective original commit: 35f64145ca1ca9ecc858222b333af4e8cb25b474 --- collects/mrlib/image-core.rkt | 151 ++++++++++++++++++---------------- 1 file changed, 80 insertions(+), 71 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 92d5a325..c7569eb5 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -142,9 +142,10 @@ has been moved out). ;; - flip ;; a bitmap is: -;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%))) +;; - (make-bitmap (is-a?/c bitmap%) angle positive-real +;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods -(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable]) +(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) #:omit-define-syntaxes #:transparent #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) @@ -568,7 +569,7 @@ has been moved out). (bitmap-angle bitmap) (* x-scale (bitmap-x-scale bitmap)) (* y-scale (bitmap-y-scale bitmap)) - #f #f)))])])) + (bitmap-cache bitmap))))])])) (define (scale-color color x-scale y-scale) (cond @@ -825,48 +826,56 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (get-rendered-bitmap flip-bitmap) - (calc-rendered-bitmap flip-bitmap) - (bitmap-rendered-bitmap (flip-shape flip-bitmap))) + (let ([key (get-bitmap-cache-key flip-bitmap)]) + (calc-rendered-bitmap flip-bitmap key) + (car (hash-ref (bitmap-cache (flip-shape flip-bitmap)) + key)))) (define (get-rendered-mask flip-bitmap) - (calc-rendered-bitmap flip-bitmap) - (bitmap-rendered-mask (flip-shape flip-bitmap))) + (let ([key (get-bitmap-cache-key flip-bitmap)]) + (calc-rendered-bitmap flip-bitmap key) + (cdr (hash-ref (bitmap-cache (flip-shape flip-bitmap)) + key)))) -(define (calc-rendered-bitmap flip-bitmap) +(define (get-bitmap-cache-key flip-bitmap) + (let ([bm (flip-shape flip-bitmap)]) + (list (flip-flipped? flip-bitmap) + (bitmap-x-scale bm) + (bitmap-y-scale bm) + (bitmap-angle bm)))) + +(define (calc-rendered-bitmap flip-bitmap key) (let ([bitmap (flip-shape flip-bitmap)]) - (unless (bitmap-rendered-bitmap bitmap) - (let ([flipped? (flip-flipped? flip-bitmap)]) - - ;; fill in the rendered bitmap with the raw bitmaps. - (set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap)) - (set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap)) - (cond - [(and (= 1 (bitmap-x-scale bitmap)) - (= 1 (bitmap-y-scale bitmap)) - (= 0 (bitmap-angle bitmap)) - (not flipped?)) - ;; if there's no scaling, rotation or flipping, we can just keep that bitmap. - (void)] - [(<= (* (bitmap-x-scale bitmap) - (bitmap-y-scale bitmap)) - 1) - ;; since we prefer to rotate big things, we rotate first - (do-rotate bitmap flipped?) - (do-scale bitmap)] - [else - ;; since we prefer to rotate big things, we scale first - (do-scale bitmap) - (do-rotate bitmap flipped?)]))))) + (cond + [(hash-ref (bitmap-cache bitmap) key #f) => (λ (x) x)] + [else + (let ([flipped? (flip-flipped? flip-bitmap)]) + (define-values (orig-bitmap-obj orig-mask-obj) (values (bitmap-raw-bitmap bitmap) + (bitmap-raw-mask bitmap))) + (define-values (bitmap-obj mask-obj) + (cond + [(<= (* (bitmap-x-scale bitmap) + (bitmap-y-scale bitmap)) + 1) + ;; since we prefer to rotate big things, we rotate first + (let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)]) + (do-scale bitmap bitmap-obj mask-obj))] + [else + ;; since we prefer to rotate big things, we scale first + (let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)]) + (do-rotate bitmap bitmap-obj mask-obj flipped?))])) + (define pair (cons bitmap-obj mask-obj)) + (hash-set! (bitmap-cache bitmap) key pair) + pair)]))) -(define (do-rotate bitmap flip?) +(define (do-rotate bitmap bitmap-obj mask-obj flip?) (cond [(and (not flip?) (zero? (bitmap-angle bitmap))) ;; don't rotate anything in this case. - (void)] + (values bitmap-obj mask-obj)] [else (let ([θ (degrees->radians (bitmap-angle bitmap))]) - (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) - (bitmap-rendered-mask bitmap))]) + (let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)]) (let-values ([(rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ)]) (let* ([flipped-bytes (if flip? @@ -874,39 +883,40 @@ the mask bitmap and the original bitmap are all together in a single bytes! rotated-bytes)] [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] [mask (send bm get-loaded-mask)]) - (set-bitmap-rendered-bitmap! bitmap bm) - (set-bitmap-rendered-mask! bitmap mask)))))])) + (values bm mask)))))])) -(define (do-scale bitmap) - (let* ([bdc (make-object bitmap-dc%)] - [orig-bm (bitmap-rendered-bitmap bitmap)] - [orig-mask (bitmap-rendered-mask bitmap)] - [orig-w (send orig-bm get-width)] - [orig-h (send orig-bm get-height)] - [x-scale (bitmap-x-scale bitmap)] - [y-scale (bitmap-y-scale bitmap)] - [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] - [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] - [new-bm (make-object bitmap% scale-w scale-h)] - [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))]) - (when new-mask - (send new-bm set-loaded-mask new-mask)) - - (send bdc set-bitmap new-bm) - (send bdc set-scale x-scale y-scale) - (send bdc clear) - (send bdc draw-bitmap orig-bm 0 0) - - (when new-mask - (send bdc set-bitmap new-mask) - (send bdc set-scale x-scale y-scale) - (send bdc clear) - (send bdc draw-bitmap orig-mask 0 0)) - - (send bdc set-bitmap #f) - - (set-bitmap-rendered-bitmap! bitmap new-bm) - (set-bitmap-rendered-mask! bitmap new-mask))) +(define (do-scale bitmap orig-bm orig-mask) + (let ([x-scale (bitmap-x-scale bitmap)] + [y-scale (bitmap-y-scale bitmap)]) + (cond + [(and (= 1 x-scale) (= 1 y-scale)) + ;; no need to scale in this case + (values orig-bm orig-mask)] + [else + (let* ([bdc (make-object bitmap-dc%)] + [orig-w (send orig-bm get-width)] + [orig-h (send orig-bm get-height)] + [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] + [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] + [new-bm (make-object bitmap% scale-w scale-h)] + [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))]) + (when new-mask + (send new-bm set-loaded-mask new-mask)) + + (send bdc set-bitmap new-bm) + (send bdc set-scale x-scale y-scale) + (send bdc clear) + (send bdc draw-bitmap orig-bm 0 0) + + (when new-mask + (send bdc set-bitmap new-mask) + (send bdc set-scale x-scale y-scale) + (send bdc clear) + (send bdc draw-bitmap orig-mask 0 0)) + + (send bdc set-bitmap #f) + + (values new-bm new-mask))]))) (define (text->font text) (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) @@ -1024,7 +1034,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [h (send bm get-height)]) (make-image (make-translate (/ w 2) (/ h 2) - (make-bitmap bm mask-bm 0 1 1 #f #f)) + (make-bitmap bm mask-bm 0 1 1 (make-hash))) (make-bb w h h) #f))) @@ -1042,9 +1052,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! (vector-set! v i nv))))]) (update 1) (update 2) - ;; don't save the rendered bitmap (if it is there) + ;; don't save the cache (vector-set! v 6 #f) - (vector-set! v 7 #f) (recur v port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1070,7 +1079,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale - bitmap-rendered-bitmap bitmap-rendered-mask + bitmap-cache make-flip flip? flip-flipped? flip-shape From 99bba880eaf0c442642e39eb207452e5246d509d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Oct 2010 14:07:12 -0600 Subject: [PATCH 050/462] adjust release notes for 5.0.2 Merge to 5.0.2 original commit: 0b73790ac0097cad30281471833f61df25184463 --- doc/release-notes/gracket/HISTORY.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/release-notes/gracket/HISTORY.txt b/doc/release-notes/gracket/HISTORY.txt index ccd6fb4f..51602102 100644 --- a/doc/release-notes/gracket/HISTORY.txt +++ b/doc/release-notes/gracket/HISTORY.txt @@ -1,3 +1,9 @@ +Version 5.0.2, October 2010 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 5.0.1, July 2010 Minor bug fixes From c0aee593ccdbef32cbef1fb1430047e3775196dd Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 26 Oct 2010 23:21:33 -0400 Subject: [PATCH 051/462] impose contract on write-animated-gif, Closes PR11358 original commit: 07952e140867be125978e05516ea0fe1591deff8 --- collects/mrlib/gif.rkt | 15 ++++++++++++--- collects/mrlib/scribblings/gif.scrbl | 6 ++++-- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/collects/mrlib/gif.rkt b/collects/mrlib/gif.rkt index 7c6f323e..17448855 100644 --- a/collects/mrlib/gif.rkt +++ b/collects/mrlib/gif.rkt @@ -4,10 +4,9 @@ scheme/class scheme/list net/gifwrite - scheme/contract) + racket/contract) - (provide write-gif - write-animated-gif) + (provide write-gif) (define (force-bm bm) (if (procedure? bm) (bm) bm)) @@ -76,6 +75,16 @@ (define (write-gif bm filename) (write-gifs (list bm) #f filename #f #f #f)) + (provide/contract + [write-animated-gif + (->i ((bms (and/c (listof (or/c (is-a?/c bitmap%) (-> (is-a?/c bitmap%)))) pair?)) + (delay (integer-in 0 4294967295)) + (filename (or/c path? string?))) + (#:one-at-a-time? (one-at-a-time? any/c) + #:last-frame-delay (last-frame-delay (or/c (integer-in 0 4294967295) false/c)) + #:loop? (Loop? (delay) (lambda (x) (and delay #t)))) + any)]) + (define (write-animated-gif bms delay filename #:one-at-a-time? [one-at-a-time? #f] #:last-frame-delay [last-frame-delay #f] diff --git a/collects/mrlib/scribblings/gif.scrbl b/collects/mrlib/scribblings/gif.scrbl index 0b4916ed..84766dd9 100644 --- a/collects/mrlib/scribblings/gif.scrbl +++ b/collects/mrlib/scribblings/gif.scrbl @@ -21,8 +21,10 @@ a simple algorithm; see @scheme[quantize]. If the bitmap has a mask bitmap via @method[bitmap% get-loaded-mask], it is used to determine transparent pixels in the generated GIF image.} -@defproc[(write-animated-gif [bitmaps (listof (or/c (is-a?/c bitmap%) - (-> (is-a?/c bitmap%))))] +@defproc[(write-animated-gif [bitmaps (and/c + (listof (or/c (is-a?/c bitmap%) + (-> (is-a?/c bitmap%)))) + pair?)] [delay-csec (integer-in 0 #xFFFFFFFF)] [filename path-string] [#:loop loop? any/c (and delay-csec #t)] From c88bace1ce23924700057270ead97be7257d0d64 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 24 Oct 2010 17:57:54 -0500 Subject: [PATCH 052/462] tightened the contract on read-snip original commit: a021403679cfa7b44c3091bd979ff6997d1f2b86 --- collects/scribblings/gui/wxme.scrbl | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/gui/wxme.scrbl b/collects/scribblings/gui/wxme.scrbl index c165b806..36f2f5d5 100644 --- a/collects/scribblings/gui/wxme.scrbl +++ b/collects/scribblings/gui/wxme.scrbl @@ -165,10 +165,12 @@ in a @tech{WXME} stream. The interface has two methods: Called at most once per @tech{WXME} stream to initialize the data type's stream-specific information. This method usually does nothing.} -@defmethod[(read-snip [text-only? Boolean?] +@defmethod[(read-snip [text-only? boolean?] [version exact-nonnegative-integer?] [stream (is-a?/c stream<%>)]) - any/c]{ + (if text-only? + bytes? + any/c)]{ Called when an instance of the data type is encountered in the stream. This method reads the data and returns either bytes to be From 0b029011dd46697e612a0507b2f9401984ef8474 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 26 Oct 2010 15:25:57 -0500 Subject: [PATCH 053/462] added support to the 2htdp/image library for reading files when there is no GUI around. currently the support is limited to images that can only report their sizes and pinholes and where equal? signals an error unless the arguments are eq?. original commit: a744958fd539471315b7515e3e9460af861aa7b7 --- collects/mrlib/image-core-wxme.rkt | 62 ++++++++++++++++++ collects/mrlib/image-core.rkt | 64 +++---------------- .../mrlib/private/image-core-snipclass.rkt | 36 +++++++++++ collects/mrlib/private/regmk.rkt | 37 +++++++++++ 4 files changed, 143 insertions(+), 56 deletions(-) create mode 100644 collects/mrlib/image-core-wxme.rkt create mode 100644 collects/mrlib/private/image-core-snipclass.rkt create mode 100644 collects/mrlib/private/regmk.rkt diff --git a/collects/mrlib/image-core-wxme.rkt b/collects/mrlib/image-core-wxme.rkt new file mode 100644 index 00000000..88906d33 --- /dev/null +++ b/collects/mrlib/image-core-wxme.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require racket/class + wxme + "private/image-core-snipclass.rkt" + "private/regmk.rkt") +(provide reader image<%>) + +(define guiless-image% + (class* object% (equal<%> image<%>) + (init-field pinhole bb) + (define/public (equal-to? that eq-recur) + (cond + [(eq? this that) #t] + [else (error 'image% "cannot do equality comparison without gui libraries")])) + (define/public (equal-hash-code-of y) 42) + (define/public (equal-secondary-hash-code-of y) 3) + + (define/public (get-shape) + (error 'image% "cannot get-shape without gui libraries")) + (define/public (set-shape s) + (error 'image% "cannot get-shape without gui libraries")) + (define/public (get-bb) bb) + (define/public (get-pinhole) pinhole) + (define/public (get-normalized?) #f) + (define/public (set-normalized? n?) (void)) + + (define/public (get-normalized-shape) + (error 'image% "cannot get-normalized-shape without gui libraries")) + + (super-new))) + +(define reader + (new + (class* object% (snip-reader<%>) + (define/public (read-header vers stream) + (void)) + (define/public (read-snip text? cvers stream) + (let* ([lst (fetch (send stream read-raw-bytes '2htdp/image))]) + (if text? + #"." + (let ([marshalled-img (list-ref lst 0)] + [marshalled-bb (list-ref lst 1)] + [marshalled-pinhole (list-ref lst 2)]) + (new guiless-image% + [bb (if (and (vector? marshalled-bb) + (= 4 (vector-length marshalled-bb)) + (eq? (vector-ref marshalled-bb 0) 'struct:bb) + (number? (vector-ref marshalled-bb 1)) + (number? (vector-ref marshalled-bb 2)) + (number? (vector-ref marshalled-bb 3))) + (apply make-bb (cdr (vector->list marshalled-bb))) + (make-bb 100 100 100))] + [pinhole + (if (and (vector? marshalled-pinhole) + (= 3 (vector-length marshalled-pinhole)) + (eq? (vector-ref marshalled-pinhole 0) 'struct:point) + (number? (vector-ref marshalled-pinhole 1)) + (number? (vector-ref marshalled-pinhole 2))) + (make-point (vector-ref marshalled-pinhole 1) + (vector-ref marshalled-pinhole 2)) + #f)]))))) + (super-new)))) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index c7569eb5..aab0febf 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -32,34 +32,13 @@ has been moved out). racket/math racket/contract "private/image-core-bitmap.ss" + "image-core-wxme.ss" + "private/image-core-snipclass.rkt" + "private/regmk.rkt" (prefix-in cis: "cache-image-snip.ss") (for-syntax racket/base)) -(define-for-syntax id-constructor-pairs '()) -(define-for-syntax (add-id-constructor-pair a b) - (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) -(define-syntax (define-struct/reg-mk stx) - (syntax-case stx () - [(_ id . rest) - (let ([build-name - (λ (fmt) - (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) - (add-id-constructor-pair (build-name "struct:~a") - (build-name "make-~a")) - #'(define-struct id . rest))])) - -(define-syntax (define-id->constructor stx) - (syntax-case stx () - [(_ fn) - #`(define (fn x) - (case x - #,@(map (λ (x) - (with-syntax ([(struct: maker) x]) - #`[(struct:) maker])) - id-constructor-pairs)))])) - -(define-struct/reg-mk point (x y) #:transparent) ; @@ -93,15 +72,11 @@ has been moved out). (define (set-image-shape! p s) (send p set-shape s)) (define (set-image-normalized?! p n?) (send p set-normalized? n?)) (define (image? p) - (or (is-a? p image%) + (or (is-a? p image<%>) (is-a? p image-snip%) (is-a? p bitmap%))) -;; a bb is (bounding box) -;; (make-bb number number number) -(define-struct/reg-mk bb (right bottom baseline) #:transparent) - ;; a shape is either: ;; ;; - (make-overlay shape shape) @@ -219,14 +194,10 @@ has been moved out). ; ;; ; ; ;;;; -(define-local-member-name - get-shape set-shape get-bb get-pinhole - get-normalized? set-normalized get-normalized-shape) - (define skip-image-equality-fast-path (make-parameter #f)) (define image% - (class* snip% (equal<%>) + (class* snip% (equal<%> image<%>) (init-field shape bb normalized? pinhole) (define/public (equal-to? that eq-recur) (or (eq? this that) @@ -346,30 +317,13 @@ has been moved out). (define image-snipclass% (class snip-class% (define/override (read f) - (let* ([bytes (send f get-unterminated-bytes)] - [str - (and bytes - (with-handlers ((exn:fail? (λ (x) #f))) - (bytes->string/utf-8 bytes)))] - [lst - (and str - (with-handlers ((exn:fail:read? (λ (x) #f))) - (parse - (racket/base:read - (open-input-string - str)))))]) + (let ([lst (parse (fetch (send f get-unterminated-bytes)))]) (cond [(not lst) (make-image (make-ellipse 100 100 0 'solid "black") (make-bb 100 100 100) #f #f)] - [(= 2 (length lst)) - ;; backwards compatibility for saved images that didn't have a pinhole - (make-image (list-ref lst 0) - (list-ref lst 1) - #f - #f)] [else (make-image (list-ref lst 0) (list-ref lst 1) @@ -379,7 +333,8 @@ has been moved out). (provide snip-class) (define snip-class (new image-snipclass%)) -(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib"))) +(send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib") + '(lib "image-core-wxme.rkt" "mrlib")))) (send snip-class set-version 1) (send (get-the-snip-class-list) add snip-class) @@ -406,9 +361,6 @@ has been moved out). (k #f)))]))] [else sexp])))) -(define-id->constructor id->constructor) - - (define (normalized-shape? s) (cond [(overlay? s) diff --git a/collects/mrlib/private/image-core-snipclass.rkt b/collects/mrlib/private/image-core-snipclass.rkt new file mode 100644 index 00000000..eac28521 --- /dev/null +++ b/collects/mrlib/private/image-core-snipclass.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require racket/class) +(provide fetch image<%> + get-shape set-shape get-bb get-pinhole + get-normalized? set-normalized get-normalized-shape) + +(define-local-member-name + get-shape set-shape get-bb get-pinhole + get-normalized? set-normalized get-normalized-shape) + +(define image<%> + (interface () + get-shape set-shape get-bb get-pinhole + get-normalized? get-normalized-shape)) + +(define (fetch bytes) + (let* ([str + (and bytes + (with-handlers ((exn:fail? (λ (x) #f))) + (bytes->string/utf-8 bytes)))] + [lst (and str + (with-handlers ((exn:fail:read? (λ (x) #f))) + (racket/base:read + (open-input-string + str))))]) + (cond + [(and (list? lst) + (= 2 (length lst))) + ;; backwards compatibility for saved images that didn't have a pinhole + (list (list-ref lst 0) + (list-ref lst 1) + #f)] + [else + lst]))) + +(define racket/base:read read) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt new file mode 100644 index 00000000..59510a43 --- /dev/null +++ b/collects/mrlib/private/regmk.rkt @@ -0,0 +1,37 @@ +#lang racket +(provide define-struct/reg-mk + id->constructor + (struct-out point) + (struct-out bb)) + +(define-for-syntax id-constructor-pairs '()) +(define-for-syntax (add-id-constructor-pair a b) + (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) + +(define-syntax (define-struct/reg-mk stx) + (syntax-case stx () + [(_ id . rest) + (let ([build-name + (λ (fmt) + (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) + (add-id-constructor-pair (build-name "struct:~a") + (build-name "make-~a")) + #'(define-struct id . rest))])) + +(define-syntax (define-id->constructor stx) + (syntax-case stx () + [(_ fn) + #`(define (fn x) + (case x + #,@(map (λ (x) + (with-syntax ([(struct: maker) x]) + #`[(struct:) maker])) + id-constructor-pairs)))])) + +(define-id->constructor id->constructor) + +(define-struct/reg-mk point (x y) #:transparent) + +;; a bb is (bounding box) +;; (make-bb number number number) +(define-struct/reg-mk bb (right bottom baseline) #:transparent) From d75777d57dfa91004b9ea376a6dae591ddc93e39 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Oct 2010 11:22:44 -0500 Subject: [PATCH 054/462] 2htdp/image: adjusted the image you get when parsing fails so that it draws inside its bounding box original commit: 02d8b5cebf9341c1d07823e9c048e751e576a50f --- collects/mrlib/image-core.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index aab0febf..9dffb18b 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -320,7 +320,7 @@ has been moved out). (let ([lst (parse (fetch (send f get-unterminated-bytes)))]) (cond [(not lst) - (make-image (make-ellipse 100 100 0 'solid "black") + (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) (make-bb 100 100 100) #f #f)] From b78887e5a919ab98e30021a4e1c68a9121582a63 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Oct 2010 13:50:16 -0500 Subject: [PATCH 055/462] added default case to avoid runtime errors when parsing bogus images original commit: abca2c91b8569f0a516c6ed9e4d4f325361f5f03 --- collects/mrlib/private/regmk.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index 59510a43..87a68f3b 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -26,7 +26,8 @@ #,@(map (λ (x) (with-syntax ([(struct: maker) x]) #`[(struct:) maker])) - id-constructor-pairs)))])) + id-constructor-pairs) + [else #f]))])) (define-id->constructor id->constructor) From 6b991a5f606197315943a85cca8520cfa55d7fc8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Oct 2010 14:16:08 -0500 Subject: [PATCH 056/462] fixed a bug in the way old 2htdp/image files were parsed (those that contain bitmaps) original commit: 7ef1e8bd907b5f18f563848346628da0dcd2406f --- collects/mrlib/image-core.rkt | 26 ++++++++++++++++++++------ collects/mrlib/private/regmk.rkt | 27 ++++++++++----------------- 2 files changed, 30 insertions(+), 23 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9dffb18b..117a1f65 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -353,12 +353,26 @@ has been moved out). ;; bitmaps are vectors with a bytes in the first field (apply bytes->bitmap (vector->list sexp))] [else - (let ([constructor (id->constructor (vector-ref sexp 0))] - [args (cdr (vector->list sexp))]) - (if (and constructor - (procedure-arity-includes? constructor (length args))) - (apply constructor (map loop args)) - (k #f)))]))] + (let* ([tag (vector-ref sexp 0)] + [args (cdr (vector->list sexp))] + [constructor (id->constructor tag)] + [arg-count (length args)] + [parsed-args (map loop args)]) + (cond + [(and constructor (procedure-arity-includes? constructor arg-count)) + (apply constructor parsed-args)] + [(and (eq? tag 'struct:bitmap) + (= arg-count 7)) + ;; we changed the arity of the bitmap constructor from old versions, + ;; so fix it up here. + (make-bitmap (list-ref parsed-args 0) + (list-ref parsed-args 1) + (list-ref parsed-args 2) + (list-ref parsed-args 3) + (list-ref parsed-args 4) + (make-hash))] + [else + (k #f)]))]))] [else sexp])))) (define (normalized-shape? s) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index 87a68f3b..171f0622 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -4,8 +4,8 @@ (struct-out point) (struct-out bb)) -(define-for-syntax id-constructor-pairs '()) -(define-for-syntax (add-id-constructor-pair a b) +(define id-constructor-pairs '()) +(define (add-id-constructor-pair a b) (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) (define-syntax (define-struct/reg-mk stx) @@ -14,22 +14,15 @@ (let ([build-name (λ (fmt) (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) - (add-id-constructor-pair (build-name "struct:~a") - (build-name "make-~a")) - #'(define-struct id . rest))])) + #`(begin + (define-struct id . rest) + (add-id-constructor-pair '#,(build-name "struct:~a") + #,(build-name "make-~a"))))])) -(define-syntax (define-id->constructor stx) - (syntax-case stx () - [(_ fn) - #`(define (fn x) - (case x - #,@(map (λ (x) - (with-syntax ([(struct: maker) x]) - #`[(struct:) maker])) - id-constructor-pairs) - [else #f]))])) - -(define-id->constructor id->constructor) +(define (id->constructor id) + (let ([line (assoc id id-constructor-pairs)]) + (and line + (list-ref line 1)))) (define-struct/reg-mk point (x y) #:transparent) From 1b32d2dab2d984cde2d02242907d37ac35d06924 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Oct 2010 15:31:19 -0500 Subject: [PATCH 057/462] fixed some bugs in the way 2htdp/images were marshalled and unmarshalled original commit: 6a414bd18afb6e53a11601781e2917539a321e1e --- collects/mrlib/image-core.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 117a1f65..270fb65d 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -345,6 +345,8 @@ has been moved out). (let loop ([sexp sexp]) (cond [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))] + [(and (immutable? sexp) (hash? sexp)) + (hash-copy sexp)] [(vector? sexp) (if (= (vector-length sexp) 0) (k #f) @@ -1019,7 +1021,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (update 1) (update 2) ;; don't save the cache - (vector-set! v 6 #f) + (vector-set! v 6 (make-hash)) (recur v port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 2f17eb823c3f388887d707115e37271a18292ca5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 29 Oct 2010 15:06:48 -0500 Subject: [PATCH 058/462] fix minor bug in 'display-end functionality in invalidate-bitmap-cache original commit: 822895fd68263aab59a32bf863e72946fea5bb6e --- collects/mred/private/wxme/text.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 5e5a4d95..1d560f3f 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -4887,7 +4887,9 @@ (min refresh-t top) top) right (if (not refresh-box-unset?) - (max bottom refresh-b) + (if (eq? refresh-b 'display-end) + bottom + (max bottom refresh-b)) bottom) #t)) (values (max refresh-l left) From bd00bd53033108ea69c24c665a60074da089d3e7 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 17:35:16 -0600 Subject: [PATCH 059/462] add first draft of a mixin for text% objects that displays line numbers original commit: dc6350244d4d324dae97e863c2fc4a38d1b1dac3 --- collects/framework/private/sig.rkt | 2 + collects/framework/private/text.rkt | 253 +++++++++++++++++++++++++++- 2 files changed, 252 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 48f83b6c..702b0178 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -163,6 +163,7 @@ (define-signature text-class^ (basic<%> first-line<%> + line-numbers<%> foreground-color<%> hide-caret/selection<%> nbsp->space<%> @@ -199,6 +200,7 @@ basic-mixin first-line-mixin + line-numbers-mixin foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 72d5bbb1..0fe9a276 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,12 +11,13 @@ WARNING: printf is rebound in the body of the unit to always scheme/class scheme/match scheme/path - "sig.ss" - "../gui-utils.ss" - "../preferences.ss" + "sig.rkt" + "../gui-utils.rkt" + "../preferences.rkt" mred/mred-sig mrlib/interactive-value-port setup/dirs + racket/list (prefix-in srfi1: srfi/1)) (require setup/xref scribble/xref @@ -3696,3 +3697,249 @@ designates the character that triggers autocompletion (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define searching% (searching-mixin backup-autosave%)) (define info% (info-mixin (editor:info-mixin searching%))) + +;; ============================================================ +;; line number text% + +(define line-numbers<%> + (interface () show-line-numbers!)) + +(define line-numbers-mixin + (mixin ((class->interface text%)) (line-numbers<%>) + (super-new) + (inherit get-visible-line-range + get-visible-position-range + find-position + line-start-position + line-end-position) + (define show-line-numbers? #t) + (define/public (show-line-numbers! what) + (set! show-line-numbers? what)) + (define old-origin-x 0) + (define old-origin-y 0) + (define cached-snips (list)) + (define need-to-recalculate-snips #f) + (define (get-style-font) + (let* ([style-list (send this get-style-list)] + [std (or (send style-list find-named-style "Standard") + #t + #; + (send style-list basic-style))]) + (send std get-font))) + + ;; get the y position of a snip + (define (get-snip-y snip) + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + (unbox y)) + + ;; returns an ordered list of snip y positions + ;; TODO: cache this list and update it incrementally + (define (snip-heights snip dc) + (define-struct snip-size (start end)) + (define (get-size snip) + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + (define width (box 0)) + (define height (box 0)) + (send snip get-extent dc (unbox x) (unbox y) width height) + (make-snip-size (unbox y) (+ (unbox y) (unbox height)))) + ;; size2 can be merged into size1 + (define (can-merge? size1 size2) + (and (between (snip-size-start size1) + (snip-size-start size2) + (snip-size-end size1)) + #; + (between (snip-size-start size1) + (snip-size-end size2) + (snip-size-end size1)))) + (define (merge-sizes sizes) + (match sizes + [(list size1 size2 rest ...) + #; + (printf "Merge ~a,~a into ~a,~a?\n" + (snip-size-start size2) (snip-size-end size2) + (snip-size-start size1) (snip-size-end size1)) + (if (can-merge? size1 size2) + (merge-sizes (cons size1 rest)) + (cons size1 (merge-sizes (cons size2 rest))))] + [else sizes])) + + (let loop ([all '()] + [snip snip]) + (if snip + (loop (cons (get-size snip) all) (send snip next)) + (map (lambda (size) + (snip-size-start size)) + (merge-sizes (remove-duplicates + (sort (reverse all) + (lambda (a b) + (< (snip-size-start a) + (snip-size-start b))))))))) + #; + (let loop ([all '()] + [snip snip]) + (if snip + (loop (cons snip all) (send snip next)) + (remove-duplicates (sort (reverse (map get-snip-y all)) <))))) + + (define (show-all-snips dc) + (define snip (send this find-first-snip)) + (newline) + (define (next snip) + (when snip + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + #; + (printf "Snip ~a at ~a,~a\n" snip (unbox x) (unbox y)) + (next (send snip next)))) + (next snip)) + + ;; a <= b <= c + (define (between low what high) + (and (>= what low) + (<= what high))) + + ;; finds the first item in the sequence for which `ok?' returns true + (define (find-first sequence ok?) + (define-values (more? get) (sequence-generate sequence)) + (let loop () + (if (more?) + (if (ok? (get)) + #t + (loop)) + #f))) + + ;; true if the `y' location is within the positions specified by the + ;; lines `start' and `end' + (define (ok-height y start end) + (define position (find-position 0 y)) + ;; this is why we need some `break' ability in for loops + (find-first (in-range start end) + (lambda (line) + (define low (line-start-position line)) + (define high (line-end-position line)) + (between low position high)))) + + (define/augment (on-insert start length) + (set! need-to-recalculate-snips #t)) + + (define (get-snip-heights dc) + (when need-to-recalculate-snips + (set! need-to-recalculate-snips #f) + (set! cached-snips (snip-heights (send this find-first-snip) dc))) + cached-snips) + + (define (draw-line-numbers dc left top right bottom dx dy) + (define start-line (box 0)) + (define end-line (box 0)) + (get-visible-line-range start-line end-line #f) + (define start-position (box 0)) + (define end-position (box 0)) + #; + (get-visible-position-range start-line end-line) + (define (draw-text . args) + (send/apply dc draw-text args)) + (define old-pen (send dc get-pen)) + #; + (send dc set-font (send this get-font)) + (send dc set-font (get-style-font)) + (define-values (font-width font-height baseline space) + (send dc get-text-extent "a")) + #; + (printf "Style list ~a\n" (send this get-style-list)) + #; + (printf "My height ~a text height ~a\n" font-height (text-height (send this get-dc) "a")) + (send dc set-text-foreground (make-object color% "black")) + #; + (send dc set-pen "red" 2 'solid) + #; + (send dc set-pen (send (send this get-dc) get-pen)) + #; + (printf "First snip at ~a\n" (send this find-first-snip)) + #; + (show-all-snips dc) + #; + (printf "Snip positions ~a\n" (snip-heights (send this find-first-snip) dc)) + + #; + (printf "Repaint from ~a to ~a dx ~a dy ~a visible ~a ~a\n" top bottom dx dy (unbox start-line) (unbox end-line)) + #; + (printf "Snips ~a\n" (snip-heights (send this find-first-snip) dc)) + + (define heights (get-snip-heights dc)) + (for ([y heights] + [line (in-naturals 1)]) + #; + (printf "ok height? ~a ~a is ~a\n" y line (ok-height y (unbox start-line) (unbox end-line))) + (when (and (ok-height y (unbox start-line) (add1 (unbox end-line))) + (between top y bottom)) + #; + (printf "~a at ~a\n" line (+ dy y)) + (draw-text (number->string line) 0 (+ dy y)))) + + #; + (for ([i (in-range top bottom font-height)] + [y (snip-heights (send this find-first-snip) dc)] + [line (in-naturals 1)]) + (define point (round (inexact->exact (/ i font-height)))) + #; + (printf "Draw ~a at ~a\n" (add1 point) point) + (printf "y ~a top ~a bottom ~a dy ~a\n" y top bottom dy) + (when (and (>= y top) + (<= y bottom)) + (draw-text (number->string (+ (unbox start-line) line)) + 0 (+ dy y))) + #; + (draw-text (number->string (+ (unbox start-line) (add1 point))) + 0 place + #; + (+ dy (* point font-height)))) + + #; + (for ([i (in-range 0 (- (unbox end-line) (unbox start-line)))]) + (draw-text (number->string (add1 i)) 0 (* i font-height))) + #; + (send dc set-pen old-pen) + #; + (define-values (line-x x1 x2 x3) + (send dc get-text-extent "10000")) + (define line-x (text-width dc "10000")) + (send dc draw-line line-x (+ dy top) line-x (+ dy bottom)) + ) + + (define (text-width dc stuff) + (define-values (font-width font-height baseline space) + (send dc get-text-extent stuff)) + font-width) + + (define (text-height dc stuff) + (define-values (font-width height baseline space) + (send dc get-text-extent stuff)) + height) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (when show-line-numbers? + (if before? + (let () + ;; save old origin and push it to the right a little bit + ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + (define-values (x y) (send dc get-origin)) + (set! old-origin-x x) + (set! old-origin-y y) + #| + (define start (box 0)) + (define end (box 0)) + (get-visible-line-range start end) + |# + (define-values (font-width font-height baseline space) + (send dc get-text-extent "10000")) + (send dc set-origin (+ x (text-width dc "100000")) y)) + (begin + (send dc set-origin old-origin-x old-origin-y) + (draw-line-numbers dc left top right bottom dx dy)))) + (super on-paint before? dc left top right bottom dx dy draw-caret)) + )) From d68731be35e880f5dac66b1760ec1c435064fefe Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 17:47:48 -0600 Subject: [PATCH 060/462] clean up line numbers implementation original commit: 281138d4b8e7340a8cc35035f39fca8766a7b87f --- collects/framework/private/text.rkt | 126 +++++++++++----------------- 1 file changed, 47 insertions(+), 79 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 0fe9a276..2a97c37d 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3702,7 +3702,7 @@ designates the character that triggers autocompletion ;; line number text% (define line-numbers<%> - (interface () show-line-numbers!)) + (interface () show-line-numbers! showing-line-numbers?)) (define line-numbers-mixin (mixin ((class->interface text%)) (line-numbers<%>) @@ -3712,13 +3712,21 @@ designates the character that triggers autocompletion find-position line-start-position line-end-position) + + (define line-numbers-color "black") (define show-line-numbers? #t) - (define/public (show-line-numbers! what) - (set! show-line-numbers? what)) (define old-origin-x 0) (define old-origin-y 0) (define cached-snips (list)) (define need-to-recalculate-snips #f) + + ;; call this method with #t or #f to turn on/off line numbers + (define/public (show-line-numbers! what) + (set! show-line-numbers? what)) + + (define/public (showing-line-numbers?) + show-line-numbers?) + (define (get-style-font) (let* ([style-list (send this get-style-list)] [std (or (send style-list find-named-style "Standard") @@ -3735,7 +3743,21 @@ designates the character that triggers autocompletion (unbox y)) ;; returns an ordered list of snip y positions - ;; TODO: cache this list and update it incrementally + ;; the point is to get a list of snips positions that define + ;; where lines start. for snips that take up more than one + ;; line, like images, subsequent snips might be merged in with + ;; the line that the image sits on. if you have + ;; 2: II + ;; IIx + ;; Where the I's represent a contiguous image and the 'x' is just a letter + ;; then the 'x' snip shouldn't produce a line, it will be on line 2 along + ;; with the I image. + ;; To compute this we just test if the 'x' snip's y position is within the + ;; bounds of the I image [I.y, I.y + I.height]. It might look like we should + ;; test if the entire bounds of the 'x' snip is within the bounds of the image, + ;; that is test the height of 'x' too, but the bottom of 'x' might be below + ;; the bottom of I. In that case they are still considered to be on the same + ;; line, so we only consider the top of 'x' (its y location). (define (snip-heights snip dc) (define-struct snip-size (start end)) (define (get-size snip) @@ -3748,25 +3770,25 @@ designates the character that triggers autocompletion (make-snip-size (unbox y) (+ (unbox y) (unbox height)))) ;; size2 can be merged into size1 (define (can-merge? size1 size2) + ;; just consider the top of the second snip (and (between (snip-size-start size1) (snip-size-start size2) (snip-size-end size1)) + ;; and ignore its bottom #; (between (snip-size-start size1) (snip-size-end size2) (snip-size-end size1)))) + ;; merge snips heights together for when snips span multiple lines (define (merge-sizes sizes) (match sizes [(list size1 size2 rest ...) - #; - (printf "Merge ~a,~a into ~a,~a?\n" - (snip-size-start size2) (snip-size-end size2) - (snip-size-start size1) (snip-size-end size1)) (if (can-merge? size1 size2) (merge-sizes (cons size1 rest)) (cons size1 (merge-sizes (cons size2 rest))))] [else sizes])) + ;; get a list of all snips, sort them, merge them (let loop ([all '()] [snip snip]) (if snip @@ -3777,14 +3799,9 @@ designates the character that triggers autocompletion (sort (reverse all) (lambda (a b) (< (snip-size-start a) - (snip-size-start b))))))))) - #; - (let loop ([all '()] - [snip snip]) - (if snip - (loop (cons snip all) (send snip next)) - (remove-duplicates (sort (reverse (map get-snip-y all)) <))))) + (snip-size-start b)))))))))) + ;; not used, just for testing (define (show-all-snips dc) (define snip (send this find-first-snip)) (newline) @@ -3824,6 +3841,9 @@ designates the character that triggers autocompletion (define high (line-end-position line)) (between low position high)))) + ;; lazily reload the snip heights + ;; this isn't quite incremental but its better than recalculating + ;; on every redraw (define/augment (on-insert start length) (set! need-to-recalculate-snips #t)) @@ -3833,80 +3853,31 @@ designates the character that triggers autocompletion (set! cached-snips (snip-heights (send this find-first-snip) dc))) cached-snips) + ;; set the dc stuff to values we want + (define (setup-dc dc) + (send dc set-font (get-style-font)) + (send dc set-text-foreground (make-object color% line-numbers-color))) + (define (draw-line-numbers dc left top right bottom dx dy) - (define start-line (box 0)) - (define end-line (box 0)) - (get-visible-line-range start-line end-line #f) - (define start-position (box 0)) - (define end-position (box 0)) - #; - (get-visible-position-range start-line end-line) (define (draw-text . args) (send/apply dc draw-text args)) (define old-pen (send dc get-pen)) + (setup-dc dc) #; - (send dc set-font (send this get-font)) - (send dc set-font (get-style-font)) (define-values (font-width font-height baseline space) (send dc get-text-extent "a")) - #; - (printf "Style list ~a\n" (send this get-style-list)) - #; - (printf "My height ~a text height ~a\n" font-height (text-height (send this get-dc) "a")) - (send dc set-text-foreground (make-object color% "black")) - #; - (send dc set-pen "red" 2 'solid) - #; - (send dc set-pen (send (send this get-dc) get-pen)) - #; - (printf "First snip at ~a\n" (send this find-first-snip)) - #; - (show-all-snips dc) - #; - (printf "Snip positions ~a\n" (snip-heights (send this find-first-snip) dc)) - - #; - (printf "Repaint from ~a to ~a dx ~a dy ~a visible ~a ~a\n" top bottom dx dy (unbox start-line) (unbox end-line)) - #; - (printf "Snips ~a\n" (snip-heights (send this find-first-snip) dc)) (define heights (get-snip-heights dc)) + (define start-line (box 0)) + (define end-line (box 0)) + (get-visible-line-range start-line end-line #f) (for ([y heights] [line (in-naturals 1)]) - #; - (printf "ok height? ~a ~a is ~a\n" y line (ok-height y (unbox start-line) (unbox end-line))) (when (and (ok-height y (unbox start-line) (add1 (unbox end-line))) (between top y bottom)) - #; - (printf "~a at ~a\n" line (+ dy y)) (draw-text (number->string line) 0 (+ dy y)))) - #; - (for ([i (in-range top bottom font-height)] - [y (snip-heights (send this find-first-snip) dc)] - [line (in-naturals 1)]) - (define point (round (inexact->exact (/ i font-height)))) - #; - (printf "Draw ~a at ~a\n" (add1 point) point) - (printf "y ~a top ~a bottom ~a dy ~a\n" y top bottom dy) - (when (and (>= y top) - (<= y bottom)) - (draw-text (number->string (+ (unbox start-line) line)) - 0 (+ dy y))) - #; - (draw-text (number->string (+ (unbox start-line) (add1 point))) - 0 place - #; - (+ dy (* point font-height)))) - - #; - (for ([i (in-range 0 (- (unbox end-line) (unbox start-line)))]) - (draw-text (number->string (add1 i)) 0 (* i font-height))) - #; - (send dc set-pen old-pen) - #; - (define-values (line-x x1 x2 x3) - (send dc get-text-extent "10000")) + ;; draw the line between the line numbers and the actual text (define line-x (text-width dc "10000")) (send dc draw-line line-x (+ dy top) line-x (+ dy bottom)) ) @@ -3930,15 +3901,12 @@ designates the character that triggers autocompletion (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) - #| - (define start (box 0)) - (define end (box 0)) - (get-visible-line-range start end) - |# (define-values (font-width font-height baseline space) (send dc get-text-extent "10000")) + ;; add an extra 0 so it looks nice (send dc set-origin (+ x (text-width dc "100000")) y)) (begin + ;; rest the origin and draw the line numbers (send dc set-origin old-origin-x old-origin-y) (draw-line-numbers dc left top right bottom dx dy)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) From 6369097889c5385f8ce648dc4ac8860ffaa85792 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 17:59:59 -0600 Subject: [PATCH 061/462] document line-numbers-mixin original commit: 32bd5c9f5fe0a829616ebd80f7e80fcf4d482a90 --- collects/scribblings/framework/text.scrbl | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index ab838d17..fa3064a8 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -1164,4 +1164,22 @@ @defclass[text:searching% (text:searching-mixin text:backup-autosave%) ()]{} @defclass[text:info% (text:info-mixin (editor:info-mixin text:searching%)) ()]{} +@defmixin[text:line-numbers-mixin (text%) (text:line-numbers<%>)]{ + + @defmethod*[#:mode override (((on-paint) void))]{ + + Draws the line numbers. + } + + @defmethod*[(((show-line-numbers! (show boolean?)) void))]{ + + Enables or disables line number drawing. + } + + @defmethod*[(((show-line-numbers?) boolean?))]{ + + Returns whether or not line drawing is enabled. + } +} + @(include-previously-extracted "main-extracts.ss" #rx"^text:") From 2388261846115feaa8f435323f81c6151405d799 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 22:05:03 -0600 Subject: [PATCH 062/462] replace the line number widget in drracket with the new mixin from the framework original commit: 4f3e87d42a788de0f11f503f31deb8bc2069e890 --- collects/framework/private/text.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 2a97c37d..7a50d817 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3714,7 +3714,7 @@ designates the character that triggers autocompletion line-end-position) (define line-numbers-color "black") - (define show-line-numbers? #t) + (init-field [show-line-numbers? #t]) (define old-origin-x 0) (define old-origin-y 0) (define cached-snips (list)) @@ -3845,7 +3845,8 @@ designates the character that triggers autocompletion ;; this isn't quite incremental but its better than recalculating ;; on every redraw (define/augment (on-insert start length) - (set! need-to-recalculate-snips #t)) + (set! need-to-recalculate-snips #t) + (inner (void) on-insert start length)) (define (get-snip-heights dc) (when need-to-recalculate-snips From 8493d469675876b664cf988fb1f6aa24e1463aa8 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 22:14:28 -0600 Subject: [PATCH 063/462] cleanup code. attempt to add preference for line numbers in the general tab. closes pr11367 original commit: 18504774f00cdff945217e36c4a5c01ed16fd5dc --- collects/framework/private/preferences.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index c1cddf1f..75b8aae3 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -454,8 +454,10 @@ the state transitions / contracts are: 'framework:autosaving-on? (string-constant auto-save-files) values values) - (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + ;; does this not belong here? + ;; (make-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers) (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) (make-check editor-panel 'framework:display-line-numbers From 7a68394411456afb24a39d8fd363ecea8f6ea5e9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 23:45:00 -0600 Subject: [PATCH 064/462] set the font before computing the distance between the line numbers and the real text. add an option to the general pane to enable line numbers original commit: eb89a429e796f4ee0ae0d8e0bd154992e36dc0dc --- collects/framework/private/text.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 7a50d817..9d7dbc58 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3902,6 +3902,7 @@ designates the character that triggers autocompletion (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) + (setup-dc dc) (define-values (font-width font-height baseline space) (send dc get-text-extent "10000")) ;; add an extra 0 so it looks nice From b444c0726d03799471f39469a59048de3037529f Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 2 Nov 2010 12:50:19 -0600 Subject: [PATCH 065/462] set clipping for regular text. minor optimization when choosing line numbers to draw original commit: 87cc623a6fd1815f4361e3117708f38989388b1a --- collects/framework/private/text.rkt | 49 +++++++++++++++++++++++------ 1 file changed, 40 insertions(+), 9 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9d7dbc58..0af9de39 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3702,7 +3702,10 @@ designates the character that triggers autocompletion ;; line number text% (define line-numbers<%> - (interface () show-line-numbers! showing-line-numbers?)) + (interface () + show-line-numbers! + showing-line-numbers? + set-line-numbers-color)) (define line-numbers-mixin (mixin ((class->interface text%)) (line-numbers<%>) @@ -3713,10 +3716,8 @@ designates the character that triggers autocompletion line-start-position line-end-position) - (define line-numbers-color "black") + (init-field [line-numbers-color "black"]) (init-field [show-line-numbers? #t]) - (define old-origin-x 0) - (define old-origin-y 0) (define cached-snips (list)) (define need-to-recalculate-snips #f) @@ -3727,6 +3728,9 @@ designates the character that triggers autocompletion (define/public (showing-line-numbers?) show-line-numbers?) + (define/public (set-line-numbers-color color) + (set! line-numbers-color color)) + (define (get-style-font) (let* ([style-list (send this get-style-list)] [std (or (send style-list find-named-style "Standard") @@ -3874,8 +3878,8 @@ designates the character that triggers autocompletion (get-visible-line-range start-line end-line #f) (for ([y heights] [line (in-naturals 1)]) - (when (and (ok-height y (unbox start-line) (add1 (unbox end-line))) - (between top y bottom)) + (when (and (between top y bottom) + (ok-height y (unbox start-line) (add1 (unbox end-line)))) (draw-text (number->string line) 0 (+ dy y)))) ;; draw the line between the line numbers and the actual text @@ -3893,23 +3897,50 @@ designates the character that triggers autocompletion (send dc get-text-extent stuff)) height) + (define old-origin-x 0) + (define old-origin-y 0) + (define old-clipping #f) (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (when show-line-numbers? (if before? (let () ;; save old origin and push it to the right a little bit ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + (define number-space "10000") + ;; add an extra 0 so it looks nice + (define number-space+1 "100000") (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) + (set! old-clipping (send dc get-clipping-region)) (setup-dc dc) (define-values (font-width font-height baseline space) - (send dc get-text-extent "10000")) - ;; add an extra 0 so it looks nice - (send dc set-origin (+ x (text-width dc "100000")) y)) + (send dc get-text-extent number-space)) + (define clipped (make-object region% dc)) + (define all (make-object region% dc)) + (define copy (make-object region% dc)) + (send all set-rectangle + (+ dx left) (+ dy top) + (- right left) (- bottom top)) + (if old-clipping + (send copy union old-clipping) + (send copy union all)) + (send clipped set-rectangle + 0 (+ dy top) + (text-width dc number-space+1) + (- bottom top)) + #; + (define (print-region name region) + (define-values (a b c d) (send region get-bounding-box)) + (printf "~a: ~a, ~a, ~a, ~a\n" name a b c d)) + (send copy subtract clipped) + (send dc set-clipping-region copy) + (send dc set-origin (+ x (text-width dc number-space+1)) y) + ) (begin ;; rest the origin and draw the line numbers (send dc set-origin old-origin-x old-origin-y) + (send dc set-clipping-region old-clipping) (draw-line-numbers dc left top right bottom dx dy)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) )) From 7c445ec6e4685b54c44333f4ab8e09ee32284bc2 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 2 Nov 2010 22:34:05 -0500 Subject: [PATCH 066/462] Adds auto-completion to LaTeX and TeX inspired keybindings original commit: bd0ebc7511c7b66dfdd0b24d68dbe27077a9a7dd --- collects/framework/private/keymap.rkt | 28 +++++++++++++++++++++------ collects/tests/framework/keys.rkt | 20 ++++++++++++++++++- 2 files changed, 41 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index acfbe10d..e6e298fd 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -7,6 +7,7 @@ mzlib/match "../preferences.ss" mrlib/tex-table + (only-in srfi/13 string-prefix? string-prefix-length) "sig.ss") (import mred^ @@ -984,17 +985,32 @@ [TeX-compress (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) + (define (meet s t) + (substring s 0 (string-prefix-length s t 0))) (λ (text event) (let ([pos (send text get-start-position)]) (when (= pos (send text get-end-position)) (let ([slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1)))]) (when slash - (let ([to-replace (assoc (send text get-text slash pos) tex-shortcut-table)]) - (when to-replace - (send text begin-edit-sequence) - (send text delete (- slash 1) pos) - (send text insert (cadr to-replace)) - (send text end-edit-sequence)))))))))] + (define entered (send text get-text slash pos)) + (define completions + (filter (λ (shortcut) (string-prefix? entered (first shortcut))) + tex-shortcut-table)) + (unless (empty? completions) + (define-values (replacement partial?) + (let ([complete-match + (findf (λ (shortcut) (equal? entered (first shortcut))) + completions)]) + (if complete-match + (values (second complete-match) #f) + (if (= 1 (length completions)) + (values (second (first completions)) #f) + (let ([tex-names (map first completions)]) + (values (foldl meet (first tex-names) (rest tex-names)) #t)))))) + (send text begin-edit-sequence) + (send text delete (if partial? slash (- slash 1)) pos) + (send text insert replacement) + (send text end-edit-sequence))))))))] [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]) ;; don't have a capital ς, just comes out as \u03A2 (or junk) diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt index 6ba89dec..2ff6c5fa 100644 --- a/collects/tests/framework/keys.rkt +++ b/collects/tests/framework/keys.rkt @@ -105,7 +105,25 @@ (make-buff-spec "abc" 2 2) (list '((#\f control)) '((right))) (list '((#\f control)) '((right))) - (list '((#\f control)) '((right)))))) + (list '((#\f control)) '((right)))) + + ;; TeX-compress tests + (make-key-spec/allplatforms + (make-buff-spec "\\ome" 4 4) + (make-buff-spec "ω" 1 1) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\sub" 4 4) + (make-buff-spec "\\subset" 7 7) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\subset" 7 7) + (make-buff-spec "⊂" 1 1) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\sub" 4 4) + (make-buff-spec "⊆" 1 1) + '(((#\\ control) (#\e) (#\\ control)))))) (define (build-open-bracket-spec str pos char) (make-key-spec (make-buff-spec str pos pos) From a7e7bb6384ad46d352a66c938632faeded40196e Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 14:56:05 -0600 Subject: [PATCH 067/462] use line locations instead of counting snips original commit: 4a69c362588381e28977a2529578911f2fc54c9b --- collects/framework/private/text.rkt | 30 +++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 0af9de39..7b3a31ff 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3713,6 +3713,7 @@ designates the character that triggers autocompletion (inherit get-visible-line-range get-visible-position-range find-position + line-location line-start-position line-end-position) @@ -3740,6 +3741,7 @@ designates the character that triggers autocompletion (send std get-font))) ;; get the y position of a snip + #; (define (get-snip-y snip) (define x (box 0)) (define y (box 0)) @@ -3762,6 +3764,7 @@ designates the character that triggers autocompletion ;; that is test the height of 'x' too, but the bottom of 'x' might be below ;; the bottom of I. In that case they are still considered to be on the same ;; line, so we only consider the top of 'x' (its y location). + #; (define (snip-heights snip dc) (define-struct snip-size (start end)) (define (get-size snip) @@ -3825,6 +3828,7 @@ designates the character that triggers autocompletion (<= what high))) ;; finds the first item in the sequence for which `ok?' returns true + #; (define (find-first sequence ok?) (define-values (more? get) (sequence-generate sequence)) (let loop () @@ -3836,6 +3840,7 @@ designates the character that triggers autocompletion ;; true if the `y' location is within the positions specified by the ;; lines `start' and `end' + #; (define (ok-height y start end) (define position (find-position 0 y)) ;; this is why we need some `break' ability in for loops @@ -3848,10 +3853,12 @@ designates the character that triggers autocompletion ;; lazily reload the snip heights ;; this isn't quite incremental but its better than recalculating ;; on every redraw + #; (define/augment (on-insert start length) (set! need-to-recalculate-snips #t) (inner (void) on-insert start length)) + #; (define (get-snip-heights dc) (when need-to-recalculate-snips (set! need-to-recalculate-snips #f) @@ -3863,6 +3870,24 @@ designates the character that triggers autocompletion (send dc set-font (get-style-font)) (send dc set-text-foreground (make-object color% line-numbers-color))) + (define (draw-line-numbers dc left top right bottom dx dy) + (define (draw-text . args) + (send/apply dc draw-text args)) + (define old-pen (send dc get-pen)) + (setup-dc dc) + (define start-line (box 0)) + (define end-line (box 0)) + (get-visible-line-range start-line end-line #f) + (for ([line (in-range (unbox start-line) (add1 (unbox end-line)))]) + (define y (line-location line)) + (when (between top y bottom) + (draw-text (number->string (add1 line)) 0 (+ dy y)))) + + ;; draw the line between the line numbers and the actual text + (define line-x (text-width dc "10000")) + (send dc draw-line line-x (+ dy top) line-x (+ dy bottom))) + + #; (define (draw-line-numbers dc left top right bottom dx dy) (define (draw-text . args) (send/apply dc draw-text args)) @@ -3880,6 +3905,8 @@ designates the character that triggers autocompletion [line (in-naturals 1)]) (when (and (between top y bottom) (ok-height y (unbox start-line) (add1 (unbox end-line)))) + (when (between (unbox start-line) (add1 line) (unbox end-line)) + (printf "y ~a line location ~a\n" y (line-location (sub1 line)))) (draw-text (number->string line) 0 (+ dy y)))) ;; draw the line between the line numbers and the actual text @@ -3904,6 +3931,9 @@ designates the character that triggers autocompletion (when show-line-numbers? (if before? (let () + ;; FIXME: Moving the origin and setting the clipping rectangle + ;; will probably go away when 'margin's are added to editors + ;; ;; save old origin and push it to the right a little bit ;; TODO: maybe allow the line numbers to be drawn on the right hand side? (define number-space "10000") From f21bdf599bcc3b503c46e7e48fde9d7ad59ea794 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 15:09:04 -0600 Subject: [PATCH 068/462] add line number interface documentation original commit: 7f56e677f41798aaeb52affddc32e05729b7e4e1 --- collects/scribblings/framework/text.scrbl | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index fa3064a8..74c739d8 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -1164,6 +1164,24 @@ @defclass[text:searching% (text:searching-mixin text:backup-autosave%) ()]{} @defclass[text:info% (text:info-mixin (editor:info-mixin text:searching%)) ()]{} +@definterface[text:line-numbers<%> ()]{ + + @defmethod*[(((show-line-numbers! (show boolean?)) void))]{ + + Enables or disables line number drawing. + } + + @defmethod*[(((show-line-numbers?) boolean?))]{ + + Returns whether or not line drawing is enabled. + } + + @defmethod*[(((set-line-numbers-color (color string?)) void?))]{ + + Sets the color of the line numbers. + } +} + @defmixin[text:line-numbers-mixin (text%) (text:line-numbers<%>)]{ @defmethod*[#:mode override (((on-paint) void))]{ @@ -1180,6 +1198,11 @@ Returns whether or not line drawing is enabled. } + + @defmethod*[(((set-line-numbers-color (color string?)) void?))]{ + + Sets the color of the line numbers. + } } @(include-previously-extracted "main-extracts.ss" #rx"^text:") From 52a60ead836755b6cb9a8c5d35aab377acb8f2f9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 15:15:54 -0600 Subject: [PATCH 069/462] clean up line numbers code original commit: 68c197f63920e1b2814beb2bb68a2c22117b6502 --- collects/framework/private/text.rkt | 170 +++------------------------- 1 file changed, 16 insertions(+), 154 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 7b3a31ff..17194413 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3707,6 +3707,7 @@ designates the character that triggers autocompletion showing-line-numbers? set-line-numbers-color)) +;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin (mixin ((class->interface text%)) (line-numbers<%>) (super-new) @@ -3719,6 +3720,12 @@ designates the character that triggers autocompletion (init-field [line-numbers-color "black"]) (init-field [show-line-numbers? #t]) + + ;; maybe make this a configurable field? + (define number-space "10000") + ;; add an extra 0 so it looks nice + (define number-space+1 (string-append number-space "0")) + (define cached-snips (list)) (define need-to-recalculate-snips #f) @@ -3740,179 +3747,37 @@ designates the character that triggers autocompletion (send style-list basic-style))]) (send std get-font))) - ;; get the y position of a snip - #; - (define (get-snip-y snip) - (define x (box 0)) - (define y (box 0)) - (send this get-snip-location snip x y) - (unbox y)) - - ;; returns an ordered list of snip y positions - ;; the point is to get a list of snips positions that define - ;; where lines start. for snips that take up more than one - ;; line, like images, subsequent snips might be merged in with - ;; the line that the image sits on. if you have - ;; 2: II - ;; IIx - ;; Where the I's represent a contiguous image and the 'x' is just a letter - ;; then the 'x' snip shouldn't produce a line, it will be on line 2 along - ;; with the I image. - ;; To compute this we just test if the 'x' snip's y position is within the - ;; bounds of the I image [I.y, I.y + I.height]. It might look like we should - ;; test if the entire bounds of the 'x' snip is within the bounds of the image, - ;; that is test the height of 'x' too, but the bottom of 'x' might be below - ;; the bottom of I. In that case they are still considered to be on the same - ;; line, so we only consider the top of 'x' (its y location). - #; - (define (snip-heights snip dc) - (define-struct snip-size (start end)) - (define (get-size snip) - (define x (box 0)) - (define y (box 0)) - (send this get-snip-location snip x y) - (define width (box 0)) - (define height (box 0)) - (send snip get-extent dc (unbox x) (unbox y) width height) - (make-snip-size (unbox y) (+ (unbox y) (unbox height)))) - ;; size2 can be merged into size1 - (define (can-merge? size1 size2) - ;; just consider the top of the second snip - (and (between (snip-size-start size1) - (snip-size-start size2) - (snip-size-end size1)) - ;; and ignore its bottom - #; - (between (snip-size-start size1) - (snip-size-end size2) - (snip-size-end size1)))) - ;; merge snips heights together for when snips span multiple lines - (define (merge-sizes sizes) - (match sizes - [(list size1 size2 rest ...) - (if (can-merge? size1 size2) - (merge-sizes (cons size1 rest)) - (cons size1 (merge-sizes (cons size2 rest))))] - [else sizes])) - - ;; get a list of all snips, sort them, merge them - (let loop ([all '()] - [snip snip]) - (if snip - (loop (cons (get-size snip) all) (send snip next)) - (map (lambda (size) - (snip-size-start size)) - (merge-sizes (remove-duplicates - (sort (reverse all) - (lambda (a b) - (< (snip-size-start a) - (snip-size-start b)))))))))) - - ;; not used, just for testing - (define (show-all-snips dc) - (define snip (send this find-first-snip)) - (newline) - (define (next snip) - (when snip - (define x (box 0)) - (define y (box 0)) - (send this get-snip-location snip x y) - #; - (printf "Snip ~a at ~a,~a\n" snip (unbox x) (unbox y)) - (next (send snip next)))) - (next snip)) - ;; a <= b <= c (define (between low what high) (and (>= what low) (<= what high))) - ;; finds the first item in the sequence for which `ok?' returns true - #; - (define (find-first sequence ok?) - (define-values (more? get) (sequence-generate sequence)) - (let loop () - (if (more?) - (if (ok? (get)) - #t - (loop)) - #f))) - - ;; true if the `y' location is within the positions specified by the - ;; lines `start' and `end' - #; - (define (ok-height y start end) - (define position (find-position 0 y)) - ;; this is why we need some `break' ability in for loops - (find-first (in-range start end) - (lambda (line) - (define low (line-start-position line)) - (define high (line-end-position line)) - (between low position high)))) - - ;; lazily reload the snip heights - ;; this isn't quite incremental but its better than recalculating - ;; on every redraw - #; - (define/augment (on-insert start length) - (set! need-to-recalculate-snips #t) - (inner (void) on-insert start length)) - - #; - (define (get-snip-heights dc) - (when need-to-recalculate-snips - (set! need-to-recalculate-snips #f) - (set! cached-snips (snip-heights (send this find-first-snip) dc))) - cached-snips) - ;; set the dc stuff to values we want (define (setup-dc dc) (send dc set-font (get-style-font)) (send dc set-text-foreground (make-object color% line-numbers-color))) - (define (draw-line-numbers dc left top right bottom dx dy) + (define (draw-numbers dc top bottom dy start-line end-line) (define (draw-text . args) (send/apply dc draw-text args)) - (define old-pen (send dc get-pen)) - (setup-dc dc) - (define start-line (box 0)) - (define end-line (box 0)) - (get-visible-line-range start-line end-line #f) - (for ([line (in-range (unbox start-line) (add1 (unbox end-line)))]) + (for ([line (in-range start-line end-line)]) (define y (line-location line)) (when (between top y bottom) - (draw-text (number->string (add1 line)) 0 (+ dy y)))) + (draw-text (number->string (add1 line)) 0 (+ dy y))))) - ;; draw the line between the line numbers and the actual text - (define line-x (text-width dc "10000")) - (send dc draw-line line-x (+ dy top) line-x (+ dy bottom))) + ;; draw the line between the line numbers and the actual text + (define (draw-separator dc top bottom dy x) + (send dc draw-line x (+ dy top) x (+ dy bottom))) - #; (define (draw-line-numbers dc left top right bottom dx dy) - (define (draw-text . args) - (send/apply dc draw-text args)) - (define old-pen (send dc get-pen)) (setup-dc dc) - #; - (define-values (font-width font-height baseline space) - (send dc get-text-extent "a")) - - (define heights (get-snip-heights dc)) (define start-line (box 0)) (define end-line (box 0)) (get-visible-line-range start-line end-line #f) - (for ([y heights] - [line (in-naturals 1)]) - (when (and (between top y bottom) - (ok-height y (unbox start-line) (add1 (unbox end-line)))) - (when (between (unbox start-line) (add1 line) (unbox end-line)) - (printf "y ~a line location ~a\n" y (line-location (sub1 line)))) - (draw-text (number->string line) 0 (+ dy y)))) - ;; draw the line between the line numbers and the actual text - (define line-x (text-width dc "10000")) - (send dc draw-line line-x (+ dy top) line-x (+ dy bottom)) - ) + ;; draw it! + (draw-numbers dc top bottom dy (unbox start-line) (add1 (unbox end-line))) + (draw-separator dc top bottom dy (text-width dc "10000"))) (define (text-width dc stuff) (define-values (font-width font-height baseline space) @@ -3936,9 +3801,6 @@ designates the character that triggers autocompletion ;; ;; save old origin and push it to the right a little bit ;; TODO: maybe allow the line numbers to be drawn on the right hand side? - (define number-space "10000") - ;; add an extra 0 so it looks nice - (define number-space+1 "100000") (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) From fcec57d8fb3f092249ba869e6630b232c4e45150 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 17:16:34 -0600 Subject: [PATCH 070/462] get the line number from the paragraph original commit: 1093b4a43060cdd1e481e8570a7293538ab201ce --- collects/framework/private/text.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 17194413..7d9e1d51 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3715,6 +3715,7 @@ designates the character that triggers autocompletion get-visible-position-range find-position line-location + line-paragraph line-start-position line-end-position) @@ -3763,7 +3764,7 @@ designates the character that triggers autocompletion (for ([line (in-range start-line end-line)]) (define y (line-location line)) (when (between top y bottom) - (draw-text (number->string (add1 line)) 0 (+ dy y))))) + (draw-text (number->string (add1 (line-paragraph line))) 0 (+ dy y))))) ;; draw the line between the line numbers and the actual text (define (draw-separator dc top bottom dy x) From 67d668337ce4e2365993c504b9fe873bbb38d7c6 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 17:58:18 -0600 Subject: [PATCH 071/462] allow line number width to increase automatically original commit: c3111c425b2a85a90a5312e343d5a9144665d252 --- collects/framework/private/text.rkt | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 7d9e1d51..4e5d429b 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3713,6 +3713,7 @@ designates the character that triggers autocompletion (super-new) (inherit get-visible-line-range get-visible-position-range + last-line find-position line-location line-paragraph @@ -3722,10 +3723,10 @@ designates the character that triggers autocompletion (init-field [line-numbers-color "black"]) (init-field [show-line-numbers? #t]) - ;; maybe make this a configurable field? - (define number-space "10000") + (define (number-space) + (number->string (max (* 10 (last-line)) 10))) ;; add an extra 0 so it looks nice - (define number-space+1 (string-append number-space "0")) + (define (number-space+1) (string-append (number-space) "0")) (define cached-snips (list)) (define need-to-recalculate-snips #f) @@ -3778,7 +3779,7 @@ designates the character that triggers autocompletion ;; draw it! (draw-numbers dc top bottom dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dy (text-width dc "10000"))) + (draw-separator dc top bottom dy (text-width dc (number-space)))) (define (text-width dc stuff) (define-values (font-width font-height baseline space) @@ -3808,7 +3809,7 @@ designates the character that triggers autocompletion (set! old-clipping (send dc get-clipping-region)) (setup-dc dc) (define-values (font-width font-height baseline space) - (send dc get-text-extent number-space)) + (send dc get-text-extent (number-space))) (define clipped (make-object region% dc)) (define all (make-object region% dc)) (define copy (make-object region% dc)) @@ -3820,7 +3821,7 @@ designates the character that triggers autocompletion (send copy union all)) (send clipped set-rectangle 0 (+ dy top) - (text-width dc number-space+1) + (text-width dc (number-space+1)) (- bottom top)) #; (define (print-region name region) @@ -3828,7 +3829,7 @@ designates the character that triggers autocompletion (printf "~a: ~a, ~a, ~a, ~a\n" name a b c d)) (send copy subtract clipped) (send dc set-clipping-region copy) - (send dc set-origin (+ x (text-width dc number-space+1)) y) + (send dc set-origin (+ x (text-width dc (number-space+1))) y) ) (begin ;; rest the origin and draw the line numbers From 729ebbabb0617c2ce0dc99922519a8361a1fc647 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Nov 2010 17:59:40 -0600 Subject: [PATCH 072/462] set minimum line width to accept 100 lines original commit: d1e44d0cc85838e4183b2a10330d6a69ec72bfd2 --- collects/framework/private/text.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 4e5d429b..6392dbee 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3724,7 +3724,7 @@ designates the character that triggers autocompletion (init-field [show-line-numbers? #t]) (define (number-space) - (number->string (max (* 10 (last-line)) 10))) + (number->string (max (* 10 (last-line)) 100))) ;; add an extra 0 so it looks nice (define (number-space+1) (string-append (number-space) "0")) From 5d8c34a4cabf74ebd71ace0dff5540366d65be9f Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 4 Nov 2010 10:57:32 -0600 Subject: [PATCH 073/462] right align numbers original commit: 9742f896f9916373f00448b3bc72f5ea86f654da --- collects/framework/private/text.rkt | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 6392dbee..d0529eea 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3722,6 +3722,9 @@ designates the character that triggers autocompletion (init-field [line-numbers-color "black"]) (init-field [show-line-numbers? #t]) + ;; whether the numbers are aligned on the left or right + ;; only two values should be 'left or 'right + (init-field [alignment 'right]) (define (number-space) (number->string (max (* 10 (last-line)) 100))) @@ -3762,10 +3765,21 @@ designates the character that triggers autocompletion (define (draw-numbers dc top bottom dy start-line end-line) (define (draw-text . args) (send/apply dc draw-text args)) + + (define right-space (text-width dc (number-space))) + (define single-space (text-width dc "0")) + (for ([line (in-range start-line end-line)]) (define y (line-location line)) (when (between top y bottom) - (draw-text (number->string (add1 (line-paragraph line))) 0 (+ dy y))))) + (define view (number->string (add1 (line-paragraph line)))) + (define final-x + (case alignment + [(left) 0] + [(right) (- right-space (text-width dc view) single-space)] + [else 0])) + (define final-y (+ dy y)) + (draw-text view final-x final-y)))) ;; draw the line between the line numbers and the actual text (define (draw-separator dc top bottom dy x) From c333bc022e76f0ce8dc3f49d0fb22d13e03946a8 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 4 Nov 2010 11:56:18 -0600 Subject: [PATCH 074/462] use a lighter color for same paragraph lines original commit: c0d504b7b84277e4b21d2ce0a97fb2d7d711df5e --- collects/framework/private/text.rkt | 77 ++++++++++++++++++++++++++++- 1 file changed, 76 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index d0529eea..38f8a213 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3762,6 +3762,72 @@ designates the character that triggers autocompletion (send dc set-font (get-style-font)) (send dc set-text-foreground (make-object color% line-numbers-color))) + (define (lighter-color color) + (define (integer number) + (inexact->exact (round number))) + ;; hue 0-360 + ;; saturation 0-1 + ;; lightness 0-1 + ;; returns rgb as float values with ranges 0-1 + (define (hsl->rgb hue saturation lightness) + (define (helper x a b) + (define x* (cond + [(< x 0) (+ x 1)] + [(> x 1) (- x 1)] + [else x])) + (cond + [(< (* x 6) 1) (+ b (* 6 (- a b) x))] + [(< (* x 6) 3) a] + [(< (* x 6) 4) (+ b (* (- a b) (- 4 (* 6 x))))] + [else b])) + + (define h (/ hue 360)) + (define a (if (< lightness 0.5) + (+ lightness (* lightness saturation)) + (- (+ lightness saturation) (* lightness saturation)))) + (define b (- (* lightness 2) a)) + (define red (helper (+ h (/ 1.0 3)) a b)) + (define green (helper h a b)) + (define blue (helper (- h (/ 1.0 3)) a b)) + (values red green blue)) + + ;; red 0-255 + ;; green 0-255 + ;; blue 0-255 + (define (rgb->hsl red green blue) + (define-values (a b c d) + (if (> red green) + (if (> red blue) + (if (> green blue) + (values red (- green blue) blue 0) + (values red (- green blue) green 0)) + (values blue (- red green) green 4)) + (if (> red blue) + (values green (- blue red) blue 2) + (if (> green blue) + (values green (- blue red) red 2) + (values blue (- red green) red 4))))) + (define hue (if (= a c) 0 + (let ([x (* 60 (+ d (/ b (- a c))))]) + (if (< x 0) (+ x 360) x)))) + (define saturation (cond + [(= a c) 0] + [(< (+ a c) 1) (/ (- a c) (+ a c))] + [else (/ (- a c) (- 2 a c))])) + (define lightness (/ (+ a c) 2)) + (values hue saturation lightness)) + ;; it would be better to convert RGB to HSL and change the + ;; L (lightness) parameter + (define-values (hue saturation lightness) + (rgb->hsl (send color red) + (send color green) + (send color blue))) + (define-values (red green blue) + (hsl->rgb hue saturation (+ 0.5 lightness))) + (make-object color% (min 255 (integer (* 255 red))) + (min 255 (integer (* 255 green))) + (min 255 (integer (* 255 blue))))) + (define (draw-numbers dc top bottom dy start-line end-line) (define (draw-text . args) (send/apply dc draw-text args)) @@ -3769,8 +3835,10 @@ designates the character that triggers autocompletion (define right-space (text-width dc (number-space))) (define single-space (text-width dc "0")) + (define last-paragraph #f) (for ([line (in-range start-line end-line)]) (define y (line-location line)) + (when (between top y bottom) (define view (number->string (add1 (line-paragraph line)))) (define final-x @@ -3779,7 +3847,14 @@ designates the character that triggers autocompletion [(right) (- right-space (text-width dc view) single-space)] [else 0])) (define final-y (+ dy y)) - (draw-text view final-x final-y)))) + (if (and last-paragraph (= last-paragraph (line-paragraph line))) + (begin + (send dc set-text-foreground (lighter-color (send dc get-text-foreground))) + (draw-text view final-x final-y) + (send dc set-text-foreground (make-object color% line-numbers-color))) + (draw-text view final-x final-y))) + + (set! last-paragraph (line-paragraph line)))) ;; draw the line between the line numbers and the actual text (define (draw-separator dc top bottom dy x) From 984005b3a12abf8c9e4f84bc87459c2f93f48636 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 31 Oct 2010 17:17:46 -0500 Subject: [PATCH 075/462] removed unused argument to normalize-image original commit: 4941aec6177f0059c3a3c09e76e391b732b8e7cc --- collects/mrlib/image-core.rkt | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 270fb65d..6776920e 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -413,12 +413,11 @@ has been moved out). (boolean? (flip-flipped? shape)) (bitmap? (flip-shape shape))))) -;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape +;; normalize-shape : shape -> normalized-shape ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. -(define/contract (normalize-shape shape [f values]) - (->* (any/c) ;; should be shape? - ((-> any/c any/c)) - normalized-shape?) +(define/contract (normalize-shape shape) + (-> any/c ;; should be shape? + normalized-shape?) (let loop ([shape shape] [dx 0] [dy 0] @@ -465,16 +464,16 @@ has been moved out). (polygon-mode shape) (scale-color (polygon-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] + (make-overlay bottom this-one) + this-one))] [(line-segment? shape) (let ([this-one (make-line-segment (scale-point (line-segment-start shape)) (scale-point (line-segment-end shape)) (scale-color (line-segment-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] + (make-overlay bottom this-one) + this-one))] [(curve-segment? shape) ;; the pull is multiplied by the distance ;; between the two points when it is drawn, @@ -488,8 +487,8 @@ has been moved out). (curve-segment-e-pull shape) (scale-color (curve-segment-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] + (make-overlay bottom this-one) + this-one))] [(or (bitmap? shape) (np-atomic-shape? shape)) (let ([shape (if (bitmap? shape) (make-flip #f shape) @@ -497,8 +496,8 @@ has been moved out). (let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one))))] + (make-overlay bottom this-one) + this-one)))] [else (error 'normalize-shape "unknown shape ~s\n" shape)]))) From ee078309842c23c4e0de424e35f4be69757ceb69 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 3 Nov 2010 17:41:23 -0500 Subject: [PATCH 076/462] 2htdp/image: changed the way drawing works, specifically avoid normalization before drawing to preserve sharing original commit: ae5cd21a1b9de4058a8b57948551f351f2def9cf --- collects/mrlib/image-core.rkt | 207 +++++++++++++++++++++++----------- 1 file changed, 144 insertions(+), 63 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 6776920e..ee1a0578 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -195,6 +195,7 @@ has been moved out). ; ;;;; (define skip-image-equality-fast-path (make-parameter #f)) +(define render-normalized (make-parameter #f)) (define image% (class* snip% (equal<%> image<%>) @@ -581,7 +582,9 @@ has been moved out). [(is-a? image image-snip%) (send dc draw-bitmap (send image get-bitmap) dx dy)] [else - (render-normalized-shape (send image get-normalized-shape) dc dx dy) + (if (render-normalized) + (render-normalized-shape (send image get-normalized-shape) dc dx dy) + (render-arbitrary-shape (send image get-shape) dc dx dy)) (let ([ph (send image get-pinhole)]) (when ph (let* ([px (point-x ph)] @@ -630,24 +633,103 @@ has been moved out). (define (render-cn-or-simple-shape shape dc dx dy) (cond [(crop? shape) - (let ([points (crop-points shape)]) - (cond - [(equal? points (last-cropped-points)) - (render-normalized-shape (crop-shape shape) dc dx dy)] - [else - (let ([old-region (send dc get-clipping-region)] - [new-region (new region% [dc dc])] - [path (polygon-points->path points)]) - (send new-region set-path path dx dy) - (when old-region (send new-region intersect old-region)) - (send dc set-clipping-region new-region) - (parameterize ([last-cropped-points points]) - (render-normalized-shape (crop-shape shape) dc dx dy)) - (send dc set-clipping-region old-region))]))] + (render-cropped-shape (crop-points shape) (crop-shape shape) (λ (s) (render-normalized-shape s dc dx dy)) dc dx dy)] [else (render-simple-shape shape dc dx dy)])) +(define (render-cropped-shape points inner-shape continue dc dx dy) + (cond + [(equal? points (last-cropped-points)) + (continue inner-shape)] + [else + (let ([old-region (send dc get-clipping-region)] + [new-region (new region% [dc dc])] + [path (polygon-points->path points)]) + (send new-region set-path path dx dy) + (when old-region (send new-region intersect old-region)) + (send dc set-clipping-region new-region) + (parameterize ([last-cropped-points points]) + (continue inner-shape)) + (send dc set-clipping-region old-region))])) + (define (render-simple-shape simple-shape dc dx dy) + (cond + [(translate? simple-shape) + (let ([dx (+ dx (translate-dx simple-shape))] + [dy (+ dy (translate-dy simple-shape))] + [np-atomic-shape (translate-shape simple-shape)]) + (render-np-atomic-shape np-atomic-shape + dc + dx dy))] + [else + (render-poly/line-segment/curve-segment simple-shape dc dx dy)])) + +(define (render-arbitrary-shape shape dc dx dy) + (let loop ([shape shape] + [dx dx] + [dy dy] + [x-scale 1] + [y-scale 1]) + (define (scale-point p) + (make-point (* x-scale (point-x p)) + (* y-scale (point-y p)))) + (cond + [(translate? shape) + (loop (translate-shape shape) + (+ dx (* x-scale (translate-dx shape))) + (+ dy (* y-scale (translate-dy shape))) + x-scale + y-scale)] + [(scale? shape) + (loop (scale-shape shape) + dx + dy + (* x-scale (scale-x shape)) + (* y-scale (scale-y shape)))] + [(overlay? shape) + (loop (overlay-bottom shape) dx dy x-scale y-scale) + (loop (overlay-top shape) dx dy x-scale y-scale)] + [(crop? shape) + (render-cropped-shape + (map scale-point (crop-points shape)) + (crop-shape shape) + (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] + [(polygon? shape) + (let* ([this-one + (make-polygon (map scale-point (polygon-points shape)) + (polygon-mode shape) + (scale-color (polygon-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(line-segment? shape) + (let ([this-one + (make-line-segment (scale-point (line-segment-start shape)) + (scale-point (line-segment-end shape)) + (scale-color (line-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(curve-segment? shape) + ;; the pull is multiplied by the distance + ;; between the two points when it is drawn, + ;; so we don't need to scale it here + (let ([this-one + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (scale-color (curve-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(or (bitmap? shape) (np-atomic-shape? shape)) + (let* ([shape (if (bitmap? shape) + (make-flip #f shape) + shape)] + [this-one (scale-np-atomic x-scale y-scale shape)]) + (render-np-atomic-shape this-one dc dx dy))] + [else + (error 'normalize-shape "unknown shape ~s\n" shape)]))) + +(define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) + (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) (cond [(polygon? simple-shape) (let ([mode (polygon-mode simple-shape)] @@ -695,54 +777,52 @@ has been moved out). (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape))) (send dc set-brush "black" 'transparent) (send dc set-smoothing 'smoothed) - (send dc draw-path path dx dy))] - [else - (let ([dx (+ dx (translate-dx simple-shape))] - [dy (+ dy (translate-dy simple-shape))] - [np-atomic-shape (translate-shape simple-shape)]) - (cond - [(ellipse? np-atomic-shape) - (let* ([path (new dc-path%)] - [ew (ellipse-width np-atomic-shape)] - [eh (ellipse-height np-atomic-shape)] - [θ (degrees->radians (ellipse-angle np-atomic-shape))] - [color (ellipse-color np-atomic-shape)] - [mode (ellipse-mode np-atomic-shape)]) - (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) - (send path ellipse 0 0 ew eh) - (send path translate (- (/ ew 2)) (- (/ eh 2))) - (send path rotate θ) - (send dc set-pen (mode-color->pen mode color)) - (send dc set-brush (mode-color->brush mode color)) - (send dc set-smoothing (mode-color->smoothing mode color)) - (send dc draw-path path dx dy)))] - [(flip? np-atomic-shape) - (let ([bm (get-rendered-bitmap np-atomic-shape)]) - (send dc draw-bitmap - bm - (- dx (/ (send bm get-width) 2)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] - [(text? np-atomic-shape) - (let ([θ (degrees->radians (text-angle np-atomic-shape))] - [font (send dc get-font)]) - (send dc set-font (text->font np-atomic-shape)) - (let ([color (get-color-arg (text-color np-atomic-shape))]) - (send dc set-text-foreground - (cond - [(string? color) - (or (send the-color-database find-color color) - (send the-color-database find-color "black"))] - [else color]))) - (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) - (let ([p (- (make-rectangular dx dy) - (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) - (send dc draw-text (text-string np-atomic-shape) - (real-part p) - (imag-part p) - #f 0 θ))))]))])) + (send dc draw-path path dx dy))])) + +(define (render-np-atomic-shape np-atomic-shape dc dx dy) + (cond + [(ellipse? np-atomic-shape) + (let* ([path (new dc-path%)] + [ew (ellipse-width np-atomic-shape)] + [eh (ellipse-height np-atomic-shape)] + [θ (degrees->radians (ellipse-angle np-atomic-shape))] + [color (ellipse-color np-atomic-shape)] + [mode (ellipse-mode np-atomic-shape)]) + (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) + (send path ellipse 0 0 ew eh) + (send path translate (- (/ ew 2)) (- (/ eh 2))) + (send path rotate θ) + (send dc set-pen (mode-color->pen mode color)) + (send dc set-brush (mode-color->brush mode color)) + (send dc set-smoothing (mode-color->smoothing mode color)) + (send dc draw-path path dx dy)))] + [(flip? np-atomic-shape) + (let ([bm (get-rendered-bitmap np-atomic-shape)]) + (send dc draw-bitmap + bm + (- dx (/ (send bm get-width) 2)) + (- dy (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (get-rendered-mask np-atomic-shape)))] + [(text? np-atomic-shape) + (let ([θ (degrees->radians (text-angle np-atomic-shape))] + [font (send dc get-font)]) + (send dc set-font (text->font np-atomic-shape)) + (let ([color (get-color-arg (text-color np-atomic-shape))]) + (send dc set-text-foreground + (cond + [(string? color) + (or (send the-color-database find-color color) + (send the-color-database find-color "black"))] + [else color]))) + (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) + (let ([p (- (make-rectangular dx dy) + (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) + (send dc draw-text (text-string np-atomic-shape) + (real-part p) + (imag-part p) + #f 0 θ))))])) (define (polygon-points->path points) (let ([path (new dc-path%)]) @@ -1064,6 +1144,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! save-image-as-bitmap skip-image-equality-fast-path + render-normalized scale-np-atomic From 29b4ae696f9ebf95f8420338022b4bf38113b042 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 5 Nov 2010 15:09:30 -0600 Subject: [PATCH 077/462] adjust x position when finding editor locations original commit: a698d89a75351a470ae9f972d0c86389fd9ff88f --- collects/framework/private/text.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 38f8a213..2b920d89 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3714,7 +3714,6 @@ designates the character that triggers autocompletion (inherit get-visible-line-range get-visible-position-range last-line - find-position line-location line-paragraph line-start-position @@ -3816,8 +3815,6 @@ designates the character that triggers autocompletion [else (/ (- a c) (- 2 a c))])) (define lightness (/ (+ a c) 2)) (values hue saturation lightness)) - ;; it would be better to convert RGB to HSL and change the - ;; L (lightness) parameter (define-values (hue saturation lightness) (rgb->hsl (send color red) (send color green) @@ -3860,6 +3857,11 @@ designates the character that triggers autocompletion (define (draw-separator dc top bottom dy x) (send dc draw-line x (+ dy top) x (+ dy bottom))) + (define line-numbers-space 0) + (define/override (find-position x y . args) + ;; adjust x position to account for line numbers + (super find-position (- x line-numbers-space) y . args)) + (define (draw-line-numbers dc left top right bottom dx dy) (setup-dc dc) (define start-line (box 0)) @@ -3919,6 +3921,7 @@ designates the character that triggers autocompletion (send copy subtract clipped) (send dc set-clipping-region copy) (send dc set-origin (+ x (text-width dc (number-space+1))) y) + (set! line-numbers-space (text-width dc (number-space+1))) ) (begin ;; rest the origin and draw the line numbers From 80563786c3301dbb4cb8945a28612df78589355e Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 5 Nov 2010 15:43:20 -0600 Subject: [PATCH 078/462] dont modify positions if line numbers arent being shown original commit: e0e3870a622627a048e548ea5db0b5acf99b9f39 --- collects/framework/private/text.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 2b920d89..45a5f49f 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3860,7 +3860,9 @@ designates the character that triggers autocompletion (define line-numbers-space 0) (define/override (find-position x y . args) ;; adjust x position to account for line numbers - (super find-position (- x line-numbers-space) y . args)) + (if show-line-numbers? + (super find-position (- x line-numbers-space) y . args) + (super find-position x y . args))) (define (draw-line-numbers dc left top right bottom dx dy) (setup-dc dc) From f58eef8582c0f23f7e075b962ea34fba9850d0a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 31 May 2010 15:19:22 -0600 Subject: [PATCH 079/462] adjust mred/private/syntax for gracket2 original commit: bcb075543c4523b126ae9f5cb3f444045772ac30 --- collects/mred/private/syntax.rkt | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/syntax.rkt b/collects/mred/private/syntax.rkt index 21b0b231..b4cc868a 100644 --- a/collects/mred/private/syntax.rkt +++ b/collects/mred/private/syntax.rkt @@ -5,8 +5,9 @@ (provide defclass defclass* def/public def/public-final def/override def/override-final define/top case-args + def/public-unimplemented define-unimplemented maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts - make-literal symbol-in make-procedure + make-literal symbol-in integer-in real-in make-procedure method-name init-name let-boxes properties field-properties init-properties @@ -100,6 +101,17 @@ (define-syntax-rule (symbol-in sym ...) (make-symbol '(sym ...))) +(define (integer-in lo hi) + (make-named-pred (lambda (v) (and (exact-integer? v) + (<= lo v hi))) + (lambda () + (format "exact integer in [~a, ~a]" lo hi)))) +(define (real-in lo hi) + (make-named-pred (lambda (v) (and (real? v) + (<= lo v hi))) + (lambda () + (format "real in [~a, ~a]" lo hi)))) + (define (make-procedure arity) (make-named-pred (lambda (p) (and (procedure? p) @@ -273,3 +285,15 @@ (define-syntax-rule (assert e) (void)) ; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e))) + +(define (unimplemented c m args) (error (if c (method-name c m) m) "unimplemented; args were ~e" + args)) + +(define-syntax (def/public-unimplemented stx) + (syntax-case stx () + [(_ id) + (with-syntax ([cname (syntax-parameter-value #'class-name)]) + #'(define/public (id . args) (unimplemented 'cname 'id args)))])) + +(define-syntax-rule (define-unimplemented id) + (define (id . args) (unimplemented #f 'id args))) From 7b32ac20654250fe358a647959678a6d20cd7d93 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 31 May 2010 16:13:37 -0600 Subject: [PATCH 080/462] gracket2 wx re-implementation start original commit: 5baba1d81ac2fbf109c4c9cafcc845d899f685ee --- collects/mred/mred.rkt | 38 +- collects/mred/private/const.rkt | 10 +- collects/mred/private/dynamic.rkt | 2 - collects/mred/private/kernel.rkt | 789 +----------------- collects/mred/private/lock.rkt | 122 +-- collects/mred/private/mrpanel.rkt | 71 +- collects/mred/private/mrtop.rkt | 4 +- collects/mred/private/wx/cocoa/button.rkt | 113 +++ collects/mred/private/wx/cocoa/canvas.rkt | 345 ++++++++ collects/mred/private/wx/cocoa/check-box.rkt | 25 + collects/mred/private/wx/cocoa/choice.rkt | 70 ++ collects/mred/private/wx/cocoa/clipboard.rkt | 12 + collects/mred/private/wx/cocoa/const.rkt | 69 ++ collects/mred/private/wx/cocoa/cursor.rkt | 34 + collects/mred/private/wx/cocoa/dc.rkt | 85 ++ collects/mred/private/wx/cocoa/dialog.rkt | 31 + collects/mred/private/wx/cocoa/frame.rkt | 242 ++++++ collects/mred/private/wx/cocoa/freeze.rkt | 44 + collects/mred/private/wx/cocoa/gauge.rkt | 61 ++ .../mred/private/wx/cocoa/group-panel.rkt | 38 + collects/mred/private/wx/cocoa/image.rkt | 85 ++ collects/mred/private/wx/cocoa/init.rkt | 6 + collects/mred/private/wx/cocoa/item.rkt | 37 + collects/mred/private/wx/cocoa/keycode.rkt | 56 ++ collects/mred/private/wx/cocoa/list-box.rkt | 188 +++++ collects/mred/private/wx/cocoa/menu-bar.rkt | 112 +++ collects/mred/private/wx/cocoa/menu-item.rkt | 26 + collects/mred/private/wx/cocoa/menu.rkt | 108 +++ collects/mred/private/wx/cocoa/message.rkt | 59 ++ collects/mred/private/wx/cocoa/panel.rkt | 42 + collects/mred/private/wx/cocoa/platform.rkt | 108 +++ collects/mred/private/wx/cocoa/pool.rkt | 14 + collects/mred/private/wx/cocoa/printer-dc.rkt | 14 + collects/mred/private/wx/cocoa/procs.rkt | 130 +++ collects/mred/private/wx/cocoa/queue.rkt | 206 +++++ collects/mred/private/wx/cocoa/radio-box.rkt | 118 +++ collects/mred/private/wx/cocoa/slider.rkt | 74 ++ collects/mred/private/wx/cocoa/tab-panel.rkt | 55 ++ collects/mred/private/wx/cocoa/types.rkt | 60 ++ collects/mred/private/wx/cocoa/utils.rkt | 59 ++ collects/mred/private/wx/cocoa/window.rkt | 325 ++++++++ collects/mred/private/wx/common/clipboard.rkt | 65 ++ collects/mred/private/wx/common/cursor.rkt | 35 + collects/mred/private/wx/common/event.rkt | 111 +++ collects/mred/private/wx/common/handlers.rkt | 28 + collects/mred/private/wx/common/local.rkt | 8 + collects/mred/private/wx/common/procs.rkt | 14 + collects/mred/private/wx/common/queue.rkt | 320 +++++++ collects/mred/private/wx/common/rbtree.rkt | 316 +++++++ collects/mred/private/wx/common/timer.rkt | 47 ++ collects/mred/private/wx/common/utils.rkt | 8 + collects/mred/private/wx/gtk/button.rkt | 78 ++ collects/mred/private/wx/gtk/canvas.rkt | 257 ++++++ collects/mred/private/wx/gtk/check-box.rkt | 38 + collects/mred/private/wx/gtk/choice.rkt | 103 +++ .../mred/private/wx/gtk/client-window.rkt | 51 ++ collects/mred/private/wx/gtk/clipboard.rkt | 142 ++++ collects/mred/private/wx/gtk/const.rkt | 122 +++ collects/mred/private/wx/gtk/cursor.rkt | 10 + collects/mred/private/wx/gtk/dc.rkt | 51 ++ collects/mred/private/wx/gtk/dialog.rkt | 28 + collects/mred/private/wx/gtk/frame.rkt | 170 ++++ collects/mred/private/wx/gtk/gauge.rkt | 55 ++ collects/mred/private/wx/gtk/gl-context.rkt | 11 + collects/mred/private/wx/gtk/group-panel.rkt | 50 ++ collects/mred/private/wx/gtk/init.rkt | 12 + collects/mred/private/wx/gtk/item.rkt | 23 + collects/mred/private/wx/gtk/keycode.rkt | 67 ++ collects/mred/private/wx/gtk/list-box.rkt | 180 ++++ collects/mred/private/wx/gtk/menu-bar.rkt | 85 ++ collects/mred/private/wx/gtk/menu-item.rkt | 9 + collects/mred/private/wx/gtk/menu.rkt | 165 ++++ collects/mred/private/wx/gtk/message.rkt | 39 + collects/mred/private/wx/gtk/panel.rkt | 47 ++ collects/mred/private/wx/gtk/pixbuf.rkt | 53 ++ collects/mred/private/wx/gtk/platform.rkt | 108 +++ collects/mred/private/wx/gtk/printer-dc.rkt | 14 + collects/mred/private/wx/gtk/procs.rkt | 126 +++ collects/mred/private/wx/gtk/queue.rkt | 133 +++ collects/mred/private/wx/gtk/radio-box.rkt | 113 +++ collects/mred/private/wx/gtk/slider.rkt | 68 ++ collects/mred/private/wx/gtk/tab-panel.rkt | 102 +++ collects/mred/private/wx/gtk/types.rkt | 73 ++ collects/mred/private/wx/gtk/utils.rkt | 117 +++ collects/mred/private/wx/gtk/widget.rkt | 54 ++ collects/mred/private/wx/gtk/window.rkt | 324 +++++++ collects/mred/private/wx/platform.rkt | 87 ++ collects/mred/private/wx/win32/button.rkt | 10 + collects/mred/private/wx/win32/canvas.rkt | 30 + collects/mred/private/wx/win32/check-box.rkt | 11 + collects/mred/private/wx/win32/choice.rkt | 14 + collects/mred/private/wx/win32/clipboard.rkt | 12 + collects/mred/private/wx/win32/cursor.rkt | 9 + collects/mred/private/wx/win32/dialog.rkt | 14 + collects/mred/private/wx/win32/frame.rkt | 30 + collects/mred/private/wx/win32/gauge.rkt | 13 + collects/mred/private/wx/win32/gl-context.rkt | 11 + .../mred/private/wx/win32/group-panel.rkt | 9 + collects/mred/private/wx/win32/item.rkt | 12 + collects/mred/private/wx/win32/list-box.rkt | 26 + collects/mred/private/wx/win32/menu-bar.rkt | 13 + collects/mred/private/wx/win32/menu-item.rkt | 9 + collects/mred/private/wx/win32/menu.rkt | 22 + collects/mred/private/wx/win32/message.rkt | 10 + collects/mred/private/wx/win32/panel.rkt | 16 + collects/mred/private/wx/win32/platform.rkt | 107 +++ collects/mred/private/wx/win32/printer-dc.rkt | 14 + collects/mred/private/wx/win32/procs.rkt | 110 +++ collects/mred/private/wx/win32/radio-box.rkt | 13 + collects/mred/private/wx/win32/slider.rkt | 11 + collects/mred/private/wx/win32/tab-panel.rkt | 9 + collects/mred/private/wx/win32/window.rkt | 43 + collects/mred/private/wxcanvas.rkt | 22 +- collects/mred/private/wxme/editor-canvas.rkt | 13 +- collects/mred/private/wxme/wx.rkt | 5 - collects/mred/private/wxpanel.rkt | 18 +- collects/mred/private/wxtextfield.rkt | 4 +- collects/mred/private/wxtop.rkt | 14 +- collects/mred/private/wxwindow.rkt | 15 - 119 files changed, 7864 insertions(+), 1009 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/button.rkt create mode 100644 collects/mred/private/wx/cocoa/canvas.rkt create mode 100644 collects/mred/private/wx/cocoa/check-box.rkt create mode 100644 collects/mred/private/wx/cocoa/choice.rkt create mode 100644 collects/mred/private/wx/cocoa/clipboard.rkt create mode 100644 collects/mred/private/wx/cocoa/const.rkt create mode 100644 collects/mred/private/wx/cocoa/cursor.rkt create mode 100644 collects/mred/private/wx/cocoa/dc.rkt create mode 100644 collects/mred/private/wx/cocoa/dialog.rkt create mode 100644 collects/mred/private/wx/cocoa/frame.rkt create mode 100644 collects/mred/private/wx/cocoa/freeze.rkt create mode 100644 collects/mred/private/wx/cocoa/gauge.rkt create mode 100644 collects/mred/private/wx/cocoa/group-panel.rkt create mode 100644 collects/mred/private/wx/cocoa/image.rkt create mode 100644 collects/mred/private/wx/cocoa/init.rkt create mode 100644 collects/mred/private/wx/cocoa/item.rkt create mode 100644 collects/mred/private/wx/cocoa/keycode.rkt create mode 100644 collects/mred/private/wx/cocoa/list-box.rkt create mode 100644 collects/mred/private/wx/cocoa/menu-bar.rkt create mode 100644 collects/mred/private/wx/cocoa/menu-item.rkt create mode 100644 collects/mred/private/wx/cocoa/menu.rkt create mode 100644 collects/mred/private/wx/cocoa/message.rkt create mode 100644 collects/mred/private/wx/cocoa/panel.rkt create mode 100644 collects/mred/private/wx/cocoa/platform.rkt create mode 100644 collects/mred/private/wx/cocoa/pool.rkt create mode 100644 collects/mred/private/wx/cocoa/printer-dc.rkt create mode 100644 collects/mred/private/wx/cocoa/procs.rkt create mode 100644 collects/mred/private/wx/cocoa/queue.rkt create mode 100644 collects/mred/private/wx/cocoa/radio-box.rkt create mode 100644 collects/mred/private/wx/cocoa/slider.rkt create mode 100644 collects/mred/private/wx/cocoa/tab-panel.rkt create mode 100644 collects/mred/private/wx/cocoa/types.rkt create mode 100644 collects/mred/private/wx/cocoa/utils.rkt create mode 100644 collects/mred/private/wx/cocoa/window.rkt create mode 100644 collects/mred/private/wx/common/clipboard.rkt create mode 100644 collects/mred/private/wx/common/cursor.rkt create mode 100644 collects/mred/private/wx/common/event.rkt create mode 100644 collects/mred/private/wx/common/handlers.rkt create mode 100644 collects/mred/private/wx/common/local.rkt create mode 100644 collects/mred/private/wx/common/procs.rkt create mode 100644 collects/mred/private/wx/common/queue.rkt create mode 100644 collects/mred/private/wx/common/rbtree.rkt create mode 100644 collects/mred/private/wx/common/timer.rkt create mode 100644 collects/mred/private/wx/common/utils.rkt create mode 100644 collects/mred/private/wx/gtk/button.rkt create mode 100644 collects/mred/private/wx/gtk/canvas.rkt create mode 100644 collects/mred/private/wx/gtk/check-box.rkt create mode 100644 collects/mred/private/wx/gtk/choice.rkt create mode 100644 collects/mred/private/wx/gtk/client-window.rkt create mode 100644 collects/mred/private/wx/gtk/clipboard.rkt create mode 100644 collects/mred/private/wx/gtk/const.rkt create mode 100644 collects/mred/private/wx/gtk/cursor.rkt create mode 100644 collects/mred/private/wx/gtk/dc.rkt create mode 100644 collects/mred/private/wx/gtk/dialog.rkt create mode 100644 collects/mred/private/wx/gtk/frame.rkt create mode 100644 collects/mred/private/wx/gtk/gauge.rkt create mode 100644 collects/mred/private/wx/gtk/gl-context.rkt create mode 100644 collects/mred/private/wx/gtk/group-panel.rkt create mode 100644 collects/mred/private/wx/gtk/init.rkt create mode 100644 collects/mred/private/wx/gtk/item.rkt create mode 100644 collects/mred/private/wx/gtk/keycode.rkt create mode 100644 collects/mred/private/wx/gtk/list-box.rkt create mode 100644 collects/mred/private/wx/gtk/menu-bar.rkt create mode 100644 collects/mred/private/wx/gtk/menu-item.rkt create mode 100644 collects/mred/private/wx/gtk/menu.rkt create mode 100644 collects/mred/private/wx/gtk/message.rkt create mode 100644 collects/mred/private/wx/gtk/panel.rkt create mode 100644 collects/mred/private/wx/gtk/pixbuf.rkt create mode 100644 collects/mred/private/wx/gtk/platform.rkt create mode 100644 collects/mred/private/wx/gtk/printer-dc.rkt create mode 100644 collects/mred/private/wx/gtk/procs.rkt create mode 100644 collects/mred/private/wx/gtk/queue.rkt create mode 100644 collects/mred/private/wx/gtk/radio-box.rkt create mode 100644 collects/mred/private/wx/gtk/slider.rkt create mode 100644 collects/mred/private/wx/gtk/tab-panel.rkt create mode 100644 collects/mred/private/wx/gtk/types.rkt create mode 100644 collects/mred/private/wx/gtk/utils.rkt create mode 100644 collects/mred/private/wx/gtk/widget.rkt create mode 100644 collects/mred/private/wx/gtk/window.rkt create mode 100644 collects/mred/private/wx/platform.rkt create mode 100644 collects/mred/private/wx/win32/button.rkt create mode 100644 collects/mred/private/wx/win32/canvas.rkt create mode 100644 collects/mred/private/wx/win32/check-box.rkt create mode 100644 collects/mred/private/wx/win32/choice.rkt create mode 100644 collects/mred/private/wx/win32/clipboard.rkt create mode 100644 collects/mred/private/wx/win32/cursor.rkt create mode 100644 collects/mred/private/wx/win32/dialog.rkt create mode 100644 collects/mred/private/wx/win32/frame.rkt create mode 100644 collects/mred/private/wx/win32/gauge.rkt create mode 100644 collects/mred/private/wx/win32/gl-context.rkt create mode 100644 collects/mred/private/wx/win32/group-panel.rkt create mode 100644 collects/mred/private/wx/win32/item.rkt create mode 100644 collects/mred/private/wx/win32/list-box.rkt create mode 100644 collects/mred/private/wx/win32/menu-bar.rkt create mode 100644 collects/mred/private/wx/win32/menu-item.rkt create mode 100644 collects/mred/private/wx/win32/menu.rkt create mode 100644 collects/mred/private/wx/win32/message.rkt create mode 100644 collects/mred/private/wx/win32/panel.rkt create mode 100644 collects/mred/private/wx/win32/platform.rkt create mode 100644 collects/mred/private/wx/win32/printer-dc.rkt create mode 100644 collects/mred/private/wx/win32/procs.rkt create mode 100644 collects/mred/private/wx/win32/radio-box.rkt create mode 100644 collects/mred/private/wx/win32/slider.rkt create mode 100644 collects/mred/private/wx/win32/tab-panel.rkt create mode 100644 collects/mred/private/wx/win32/window.rkt diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 3127506f..88477ae2 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -38,20 +38,10 @@ "private/gdi.ss" "private/snipfile.ss" "private/repl.ss" - "private/afm.ss" "private/helper.ss" "private/dynamic.ss" "private/check.ss") - ;; Initialize AFM/PS: - (wx:set-ps-procs - afm-draw-text - afm-get-text-extent - afm-expand-name - afm-glyph-exists? - afm-record-font - afm-fonts-string) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box) @@ -194,17 +184,22 @@ get-panel-background send-event gl-context<%> - gl-config%) + gl-config% - (define the-color-database (wx:get-the-color-database)) - (define the-font-name-directory (wx:get-the-font-name-directory)) + the-color-database + the-font-name-directory + the-font-list + the-pen-list + the-brush-list + the-style-list + the-editor-wordbreak-map) + (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) - (define the-font-list (wx:get-the-font-list)) - (define the-pen-list (wx:get-the-pen-list)) - (define the-brush-list (wx:get-the-brush-list)) - (define the-style-list wx:the-style-list) - (define the-editor-wordbreak-map wx:the-editor-wordbreak-map) + + ;; Obsolete + (define current-ps-afm-file-paths (make-parameter null)) + (define current-ps-cmap-file-paths (make-parameter null)) (provide button% canvas% @@ -292,13 +287,6 @@ send-message-to-window the-clipboard the-x-selection-clipboard - the-editor-wordbreak-map - the-brush-list - the-color-database - the-font-name-directory - the-pen-list - the-font-list - the-style-list normal-control-font small-control-font tiny-control-font diff --git a/collects/mred/private/const.rkt b/collects/mred/private/const.rkt index 7964d97a..8bf30879 100644 --- a/collects/mred/private/const.rkt +++ b/collects/mred/private/const.rkt @@ -60,11 +60,11 @@ (define black-color (make-object wx:color% 0 0 0)) (define disabled-color (make-object wx:color% 150 150 150)) - (define trans-pen (send (wx:get-the-pen-list) find-or-create-pen "white" 0 'transparent)) - (define light-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e1.35) 0 'solid)) - (define border-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.85) 0 'solid)) - (define dark-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.6) 0 'solid)) - (define dark-brush (send (wx:get-the-brush-list) find-or-create-brush (scale-color bg-color #e0.8) 'solid)) + (define trans-pen (send wx:the-pen-list find-or-create-pen "white" 0 'transparent)) + (define light-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e1.35) 0 'solid)) + (define border-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.85) 0 'solid)) + (define dark-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.6) 0 'solid)) + (define dark-brush (send wx:the-brush-list find-or-create-brush (scale-color bg-color #e0.8) 'solid)) (define wx-tab-group<%> (interface ())) (define wx-group-box<%> (interface ())) diff --git a/collects/mred/private/dynamic.rkt b/collects/mred/private/dynamic.rkt index 0ef4b128..0fd5c23f 100644 --- a/collects/mred/private/dynamic.rkt +++ b/collects/mred/private/dynamic.rkt @@ -6,6 +6,4 @@ (provide kernel-initialized) -(dynamic-require ''#%mred-kernel #f) - (define kernel-initialized 'done) diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 7b5042e6..225f28e5 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -1,759 +1,36 @@ +#lang racket/base +(require "wx/platform.rkt" + "wx/common/event.rkt" + "wx/common/timer.rkt" + "wx/common/queue.rkt" + "wx/common/clipboard.rkt" + "wx/common/cursor.rkt" + "wx/common/gl-config.rkt" + "wx/common/procs.rkt" + racket/class + racket/draw) -;; The parts of kernel.ss are generated by xctocc. -;; kernel.ss is generated by a target in /mred/wxs/Makefile. +(define gl-context<%> (class->interface gl-context%)) -(module kernel mzscheme - (require (all-except mzlib/class object%)) +(provide (all-from-out "wx/platform.rkt") + clipboard<%> + gl-context<%> + (all-from-out "wx/common/event.rkt" + "wx/common/timer.rkt" + "wx/common/clipboard.rkt" + "wx/common/cursor.rkt" + "wx/common/gl-config.rkt" + "wx/common/procs.rkt") + (all-from-out racket/draw) - ;; Pull pieces out of #%mred-kernel dynamically, so that - ;; the library compiles with setup-plt in mzscheme. - - (define kernel:initialize-primitive-object - (dynamic-require ''#%mred-kernel 'initialize-primitive-object)) - (define kernel:primitive-class-find-method - (dynamic-require ''#%mred-kernel 'primitive-class-find-method)) - (define kernel:primitive-class-prepare-struct-type! - (dynamic-require ''#%mred-kernel 'primitive-class-prepare-struct-type!)) - - (define-syntax define-constant - (lambda (stx) - (syntax-case stx () - [(_ name) - (with-syntax ([kernel:name (datum->syntax-object - (syntax name) - (string->symbol - (format - "kernel:~a" - (syntax-e (syntax name)))) - #f)]) - (syntax - (begin - (define kernel:name (dynamic-require ''#%mred-kernel 'name)) - (provide (protect (rename kernel:name name))))))]))) - - (define-syntax define-function - (lambda (stx) - (syntax-case stx () - [(_ name) - (syntax (define-constant name))]))) - - (define-syntax define-functions - (lambda (stx) - (syntax-case stx () - [(_ name ...) - (syntax (begin (define-function name) ...))]))) - - (define-syntax define-a-class - (let ([defined null]) - (lambda (stx) - (syntax-case stx () - [(_ name print-name super (intf ...) args id ...) - (let ([nm (syntax-e (syntax name))] - [sn (syntax-e (syntax super))] - [ids (map syntax-e (syntax->list (syntax (id ...))))]) - ;; find superclass - (let ([sup (assoc sn defined)]) - (unless (or sup (not sn)) - (raise-syntax-error - 'class - "class not yet defined" - stx - (syntax super))) - ;; add this class to the list: - (set! defined (cons (cons nm (append (if sup - (cdr sup) - null) - ids)) - defined)) - (let-values ([(old new) - (let loop ([l ids][o null][n null]) - (cond - [(null? l) (values o n)] - [(memq (car l) (cdr sup)) - (loop (cdr l) (cons (car l) o) n)] - [else - (loop (cdr l) o (cons (car l) n))]))]) - (with-syntax ([(old ...) (datum->syntax-object #f old #f)] - [(new ...) (datum->syntax-object #f new #f)]) - (syntax - (define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) - (make-primitive-class - (lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props) - (kernel:primitive-class-prepare-struct-type! - c prop:object class preparer dispatcher prop:unwrap unwrapper more-props)) - kernel:initialize-primitive-object - 'print-name super (list intf ...) 'args - '(old ...) - '(new ...) - (list - (kernel:primitive-class-find-method c 'old) - ...) - (list - (kernel:primitive-class-find-method c 'new) - ...)))))))))])))) - - (define-syntax define-class - (lambda (stx) - (syntax-case stx () - [(_ name super args id ...) - (syntax - (begin - (define-a-class name name super args id ...) - (provide (protect name))))]))) - - (define-syntax define-private-class - (lambda (stx) - (syntax-case stx () - [(_ name intf super args id ...) - (syntax - (begin - (define-a-class name intf super args id ...) - (define intf (class->interface name)) - (provide (protect intf))))]))) - (define-class object% #f () #f) - (define-class window% object% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - get-handle - is-enabled-to-root? - is-shown-to-root? - set-phantom-size - get-y - get-x - get-width - get-height - popup-menu - center - get-text-extent - get-parent - refresh - screen-to-client - client-to-screen - drag-accept-files - enable - get-position - get-client-size - get-size - fit - is-shown? - show - set-cursor - move - set-size - set-focus - gets-focus? - centre) - (define-class item% window% () #f - set-label - get-label - command) - (define-class message% item% () #f - get-font - set-label - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class bitmap% object% () #f - get-argb-pixels - get-gl-config - set-gl-config - set-loaded-mask - get-loaded-mask - save-file - load-file - is-color? - ok? - get-width - get-height - get-depth) - (define-class button% item% () #f - set-border - set-label - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class choice% item% () #f - set-selection - get-selection - number - clear - append - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-function set-combo-box-font) - (define-class check-box% item% () #f - set-label - set-value - get-value - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class canvas% window% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - get-canvas-background - set-canvas-background - set-background-to-gray - on-scroll - set-scroll-page - set-scroll-range - set-scroll-pos - get-scroll-page - get-scroll-range - get-scroll-pos - scroll - warp-pointer - view-start - set-resize-corner - show-scrollbars - set-scrollbars - get-virtual-size - get-dc - on-char - on-event - on-paint) - (define-private-class dc% dc<%> object% () #f - cache-font-metrics-key - get-alpha - set-alpha - glyph-exists? - end-page - end-doc - start-page - start-doc - ok? - get-gl-context - get-size - get-text-foreground - get-text-background - get-pen - get-font - get-brush - get-text-mode - get-background - get-origin - get-scale - set-origin - set-scale - set-text-mode - try-color - draw-bitmap - draw-bitmap-section - get-char-width - get-char-height - get-text-extent - get-smoothing - set-smoothing - set-text-foreground - set-text-background - set-brush - set-pen - set-font - set-background - get-clipping-region - set-clipping-region - set-clipping-rect - draw-polygon - draw-lines - draw-path - draw-ellipse - draw-arc - draw-text - draw-spline - draw-rounded-rectangle - draw-rectangle - draw-point - draw-line - clear) - (define-function draw-tab) - (define-function draw-tab-base) - (define-class bitmap-dc% dc% () () - get-bitmap - set-bitmap - draw-bitmap-section-smooth - set-argb-pixels - get-argb-pixels - set-pixel - get-pixel) - (define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t])) - (define-class printer-dc% dc% () ([parent #f])) - (define-private-class gl-context% gl-context<%> object% () #f - call-as-current - swap-buffers - ok?) - (define-class gl-config% object% () #f - get-double-buffered - set-double-buffered - get-stereo - set-stereo - get-stencil-size - set-stencil-size - get-accum-size - set-accum-size - get-depth-size - set-depth-size - get-multisample-size - set-multisample-size) - (define-class event% object% () ([time-stamp 0]) - get-time-stamp - set-time-stamp) - (define-class control-event% event% () (event-type [time-stamp 0]) - get-event-type - set-event-type) - (define-class popup-event% control-event% () #f - get-menu-id - set-menu-id) - (define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0]) - get-event-type - set-event-type - get-direction - set-direction - get-position - set-position) - (define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f]) - set-other-caps-key-code - get-other-caps-key-code - set-other-shift-altgr-key-code - get-other-shift-altgr-key-code - set-other-altgr-key-code - get-other-altgr-key-code - set-other-shift-key-code - get-other-shift-key-code - get-key-code - set-key-code - get-key-release-code - set-key-release-code - get-shift-down - set-shift-down - get-control-down - set-control-down - get-meta-down - set-meta-down - get-alt-down - set-alt-down - get-caps-down - set-caps-down - get-x - set-x - get-y - set-y) - (define-function key-symbol-to-integer) - (define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f]) - moving? - leaving? - entering? - dragging? - button-up? - button-down? - button-changed? - get-event-type - set-event-type - get-left-down - set-left-down - get-middle-down - set-middle-down - get-right-down - set-right-down - get-shift-down - set-shift-down - get-control-down - set-control-down - get-meta-down - set-meta-down - get-alt-down - set-alt-down - get-caps-down - set-caps-down - get-x - set-x - get-y - set-y) - (define-class frame% window% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - on-toolbar-click - on-menu-click - on-menu-command - on-mdi-activate - enforce-size - on-close - on-activate - designate-root-frame - system-menu - set-modified - create-status-line - is-maximized? - maximize - status-line-exists? - iconized? - set-status-text - get-menu-bar - set-menu-bar - set-icon - iconize - set-title) - (define-class gauge% item% () #f - get-value - set-value - get-range - set-range - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class font% object% () #f - screen-glyph-exists? - get-font-id - get-size-in-pixels - get-underlined - get-smoothing - get-weight - get-point-size - get-style - get-face - get-family) - (define-class font-list% object% () #f - find-or-create-font) - (define-class color% object% () #f - blue - green - red - set - ok? - copy-from) - (define-private-class color-database% color-database<%> object% () #f - find-color) - (define-class point% object% () #f - get-x - set-x - get-y - set-y) - (define-class brush% object% () #f - set-style - get-style - set-stipple - get-stipple - set-color - get-color) - (define-class brush-list% object% () #f - find-or-create-brush) - (define-class pen% object% () #f - set-style - get-style - set-stipple - get-stipple - set-color - get-color - set-join - get-join - set-cap - get-cap - set-width - get-width) - (define-class pen-list% object% () #f - find-or-create-pen) - (define-class cursor% object% () #f - ok?) - (define-class region% object% () (dc) - in-region? - is-empty? - get-bounding-box - xor - subtract - intersect - union - set-path - set-arc - set-polygon - set-ellipse - set-rounded-rectangle - set-rectangle - get-dc) - (define-class dc-path% object% () #f - get-bounding-box - append - reverse - rotate - scale - translate - lines - ellipse - rounded-rectangle - rectangle - curve-to - arc - line-to - move-to - open? - close - reset) - (define-private-class font-name-directory% font-name-directory<%> object% () #f - find-family-default-font-id - find-or-create-font-id - get-family - get-face-name - get-font-id - set-post-script-name - set-screen-name - get-post-script-name - get-screen-name) - (define-function get-control-font-size) - (define-function get-the-font-name-directory) - (define-function get-the-font-list) - (define-function get-the-pen-list) - (define-function get-the-brush-list) - (define-function get-the-color-database) - (define-function cancel-quit) - (define-function fill-private-color) - (define-function flush-display) - (define-function yield) - (define-function write-resource) - (define-function get-resource) - (define-function label->plain-label) - (define-function display-origin) - (define-function display-size) - (define-function bell) - (define-function hide-cursor) - (define-function end-busy-cursor) - (define-function is-busy?) - (define-function begin-busy-cursor) - (define-function get-display-depth) - (define-function is-color-display?) - (define-function file-selector) - (define-class list-box% item% () #f - get-label-font - set-string - set-first-visible-item - set - get-selections - get-first-item - number-of-visible-items - number - get-selection - set-data - get-data - selected? - set-selection - select - delete - clear - append - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class menu% object% () #f - select - get-font - set-width - set-title - set-label - set-help-string - number - enable - check - checked? - append-separator - delete-by-position - delete - append) - (define-class menu-bar% object% () #f - set-label-top - number - enable-top - delete - append) - (define-class menu-item% object% () #f - id) - (define-function id-to-menu-item) - (define-class timer% object% () () - stop - start - notify - interval) - (define-private-class clipboard% clipboard<%> object% () #f - same-clipboard-client? - get-clipboard-bitmap - set-clipboard-bitmap - get-clipboard-data - get-clipboard-string - set-clipboard-string - set-clipboard-client) - (define-function get-the-x-selection) - (define-function get-the-clipboard) - (define-class clipboard-client% object% () () - same-eventspace? - get-types - add-type - get-data - on-replaced) - (define-class ps-setup% object% () () - copy-from - set-margin - set-editor-margin - set-level-2 - set-paper-name - set-translation - set-scaling - set-orientation - set-mode - set-preview-command - set-file - set-command - get-margin - get-editor-margin - get-level-2 - get-paper-name - get-translation - get-scaling - get-orientation - get-mode - get-preview-command - get-file - get-command) - (define-function show-print-setup) - (define-function can-show-print-setup?) - (define-class panel% window% () #f - get-label-position - set-label-position - on-char - on-event - on-paint - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - set-item-cursor - get-item-cursor) - (define-class dialog% window% () #f - system-menu - set-title - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - enforce-size - on-close - on-activate) - (define-class radio-box% item% () #f - button-focus - enable - set-selection - number - get-selection - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class slider% item% () #f - set-value - get-value - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class tab-group% item% () #f - button-focus - set - set-label - delete - append - enable - set-selection - number - get-selection - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class group-box% item% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - - ;; Functions defined in wxscheme.cxx - (define-functions - special-control-key - special-option-key - application-file-handler - application-quit-handler - application-about-handler - application-pref-handler - get-color-from-user - get-font-from-user - get-face-list - get-panel-background - play-sound - make-eventspace - current-eventspace - event-dispatch-handler - eventspace? - current-ps-setup - queue-callback - middle-queue-key - check-for-break - find-graphical-system-path - get-top-level-windows - register-collecting-blit - unregister-collecting-blit - shortcut-visible-in-label? - eventspace-shutdown? - in-atomic-region - set-menu-tester - location->window - set-dialogs - set-executer - send-event - file-creator-and-type - set-ps-procs - main-eventspace? - eventspace-handler-thread - begin-refresh-sequence - end-refresh-sequence - run-printout - get-double-click-time) - -) -;; end + eventspace? + current-eventspace + queue-event + yield + make-eventspace + event-dispatch-handler + eventspace-shutdown? + main-eventspace? + eventspace-handler-thread + queue-callback + middle-queue-key) diff --git a/collects/mred/private/lock.rkt b/collects/mred/private/lock.rkt index cf5969e9..21694347 100644 --- a/collects/mred/private/lock.rkt +++ b/collects/mred/private/lock.rkt @@ -1,118 +1,9 @@ (module lock mzscheme - (require (prefix wx: "kernel.ss")) - (provide (protect as-entry - as-exit - entry-point - mk-param)) - - ;; ;;;;;;;;;;;;; Thread Safety ;;;;;;;;;;;;;;;;;;;; - - ;; When the user creates an object or calls a method, or when the - ;; system invokes a callback, many steps may be required to initialize - ;; or reset fields to maintain invariants. To ensure that other - ;; threads do not call methods during a time when invariants do not - ;; hold, we force all of the following code to be executed in a single - ;; threaded manner, and we temporarily disable breaks. This accompiled - ;; with a single monitor: all entry points into the code use - ;; `entry-point' or `as-entry', and all points with this code that - ;; call back out to user code uses `as-exit'. - - ;; If an exception is raised within an `enter'ed area, control is - ;; moved back outside by the exception handler, and then the exception - ;; is re-raised. The user can't tell that the exception was caught an - ;; re-raised. But without the catch-and-reraise, the user's exception - ;; handler might try to use GUI elements from a different thread, - ;; leading to deadlock. - - (define monitor-sema (make-semaphore 1)) - (define monitor-owner #f) - - ;; An exception may be constructed while we're entered: - (define entered-err-string-handler - (lambda (s n) - (as-exit - (lambda () - ((error-value->string-handler) s n))))) - - (define old-paramz #f) - (define old-break-paramz #f) - - (define exited-key (gensym 'as-exit)) - (define lock-tag (make-continuation-prompt-tag 'lock)) - - (define (as-entry f) - (cond - [(eq? monitor-owner (current-thread)) - (f)] - [else - (with-continuation-mark - exited-key - #f - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () - (wx:in-atomic-region monitor-sema) - (set! monitor-owner (current-thread))) - (lambda () - (set! old-paramz (current-parameterization)) - (set! old-break-paramz (current-break-parameterization)) - (parameterize ([error-value->string-handler entered-err-string-handler]) - (parameterize-break - #f - (call-with-exception-handler - (lambda (exn) - ;; Get out of atomic region before letting - ;; an exception handler work - (if (continuation-mark-set-first #f exited-key) - exn ; defer to previous exn handler - (abort-current-continuation - lock-tag - (lambda () (raise exn))))) - f)))) - (lambda () - (set! monitor-owner #f) - (set! old-paramz #f) - (set! old-break-paramz #f) - (semaphore-post monitor-sema) - (wx:in-atomic-region #f)))) - lock-tag - (lambda (t) (t))))])) - - (define (as-exit f) - ;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area")) - (let ([paramz old-paramz] - [break-paramz old-break-paramz]) - (with-continuation-mark - exited-key - #t ; disables special exception handling - (call-with-parameterization - paramz - (lambda () - (call-with-break-parameterization - break-paramz - (lambda () - (dynamic-wind - (lambda () - (set! monitor-owner #f) - (semaphore-post monitor-sema) - (wx:in-atomic-region #f)) - f - (lambda () - (set! old-paramz paramz) - (set! old-break-paramz break-paramz) - (wx:in-atomic-region monitor-sema) - (set! monitor-owner (current-thread))))))))))) - - (define-syntax entry-point - (lambda (stx) - (syntax-case stx (lambda case-lambda) - [(_ (lambda args body1 body ...)) - (syntax (lambda args (as-entry (lambda () body1 body ...))))] - [(_ (case-lambda [vars body1 body ...] ...)) - (syntax (case-lambda - [vars (as-entry (lambda () body1 body ...))] - ...))]))) + (require racket/draw/lock) + (provide as-entry + as-exit + entry-point + (protect mk-param)) (define-syntax mk-param (lambda (stx) @@ -126,6 +17,3 @@ (unless (eq? v2 val) (set! val v2) (force-redraw)))]))])))) - - - diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index e78fe881..0fa10e39 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -29,6 +29,8 @@ container%-keywords area%-keywords) + (define-local-member-name get-initial-label) + (define pane% (class100*/kw (make-subarea% (make-container% area%)) () [(parent) pane%-keywords] @@ -43,12 +45,15 @@ (check-container-parent cwho parent) (as-entry (lambda () - (super-init (lambda () (set! wx (make-object (case who - [(vertical-pane) wx-vertical-pane%] - [(horizontal-pane) wx-horizontal-pane%] - [(grow-box-spacer-pane) wx-grow-box-pane%] - [else wx-pane%]) - this this (mred->wx-container parent) null)) wx) + (super-init (lambda () + (set! wx (make-object (case who + [(vertical-pane) wx-vertical-pane%] + [(horizontal-pane) wx-horizontal-pane%] + [(grow-box-spacer-pane) wx-grow-box-pane%] + [else wx-pane%]) + this this (mred->wx-container parent) null + #f)) + wx) (lambda () wx) (lambda () (check-container-ready cwho parent)) @@ -70,6 +75,7 @@ (class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) [(parent [style null]) panel%-keywords] (private-field [wx #f]) + (public [get-initial-label (lambda () #f)]) (sequence (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p [(is-a? this tab-panel%) 'tab-panel] @@ -83,10 +89,14 @@ (as-entry (lambda () (super-init (lambda () (set! wx (make-object (case who - [(vertical-panel tab-panel group-box-panel) wx-vertical-panel%] + [(vertical-panel) wx-vertical-panel%] + [(tab-panel) wx-vertical-tab-panel%] + [(group-box-panel) wx-vertical-group-panel%] [(horizontal-panel) wx-horizontal-panel%] [else wx-panel%]) - this this (mred->wx-container parent) style)) wx) + this this (mred->wx-container parent) style + (get-initial-label))) + wx) (lambda () wx) (lambda () (check-container-ready cwho parent)) #f parent #f) @@ -112,6 +122,9 @@ (define tab-panel% (class100*/kw vertical-panel% () [(choices parent [callback (lambda (b e) (void))] [style null] [font no-val]) panel%-keywords] + (private-field [save-choices choices]) + (override [get-initial-label (lambda () save-choices)]) + (sequence (let ([cwho '(constructor tab-panel)]) (unless (and (list? choices) (andmap label-string? choices)) @@ -124,19 +137,6 @@ '(deleted) null))) - (private-field - [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) - (if (memq 'no-border style) - null - '(border)) - font)]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) - - (private-field - [save-choices (map string->immutable-string choices)] - [hidden-tabs? #f]) - (public [get-number (lambda () (length save-choices))] [append (entry-point @@ -144,13 +144,13 @@ (check-label-string '(method tab-panel% append) n) (let ([n (string->immutable-string n)]) (set! save-choices (list-append save-choices (list n))) - (send (mred->wx tabs) append n))))] + (send (mred->wx this) append n))))] [get-selection (lambda () (and (pair? save-choices) - (send (mred->wx tabs) get-selection)))] + (send (mred->wx this) get-selection)))] [set-selection (entry-point (lambda (i) (check-item 'set-selection i) - (send (mred->wx tabs) set-selection i)))] + (send (mred->wx this) set-selection i)))] [delete (entry-point (lambda (i) (check-item 'delete i) @@ -158,7 +158,7 @@ (if (= p i) (cdr l) (cons (car l) (loop (add1 p) (cdr l)))))) - (send (mred->wx tabs) delete i)))] + (send (mred->wx this) delete i)))] [set-item-label (entry-point (lambda (i s) (check-item 'set-item-label i) @@ -168,14 +168,14 @@ (if (zero? i) (cons s (cdr save-choices)) (cons (car save-choices) (loop (cdr save-choices) (sub1 i)))))) - (send (mred->wx tabs) set-label i s))))] + (send (mred->wx this) set-label i s))))] [set (entry-point (lambda (l) (unless (and (list? l) (andmap label-string? l)) (raise-type-error (who->name '(method tab-panel% set)) "list of strings (up to 200 characters)" l)) (set! save-choices (map string->immutable-string l)) - (send (mred->wx tabs) set l)))] + (send (mred->wx this) set l)))] [get-item-label (entry-point (lambda (i) (check-item 'get-item-label i) @@ -194,10 +194,13 @@ m (sub1 m))) n))))]))) - (define group-box-panel% (class100*/kw vertical-panel% () [(label parent [style null] [font no-val]) panel%-keywords] + (private-field + [lbl label]) + (override [get-initial-label (lambda () lbl)]) + (sequence (let ([cwho '(constructor group-box-panel)]) (check-label-string cwho label) @@ -211,14 +214,8 @@ (when (eq? vert-margin no-val) (set! vert-margin 2)) (super-init parent (if (memq 'deleted style) - '(deleted) - null))) - - (private-field - [gbox (make-object group-box% label this null font)] - [lbl label]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) + '(deleted) + null))) (override [set-label (entry-point @@ -227,5 +224,5 @@ (set! lbl (if (immutable? s) s (string->immutable-string s))) - (send gbox set-label s)))] + (send (mred->wx this) set-label s)))] [get-label (lambda () lbl)])))) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index ef591530..719588d9 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -114,7 +114,7 @@ [wx-panel #f] [finish (entry-point (lambda (top-level hide-panel?) - (set! wx-panel (make-object wx-vertical-panel% #f this top-level null)) + (set! wx-panel (make-object wx-vertical-panel% #f this top-level null #f)) (send (send wx-panel area-parent) add-child wx-panel) (send top-level set-container wx-panel) (when hide-panel? @@ -228,7 +228,7 @@ (lambda () (super-init (lambda (finish) (set! wx (finish (make-object wx-dialog% this this - (and parent (mred->wx parent)) label #t + (and parent (mred->wx parent)) label (or x -11111) (or y -11111) (or width 0) (or height 0) style) #f)) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt new file mode 100644 index 00000000..3b6fe436 --- /dev/null +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -0,0 +1,113 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "window.rkt" + "../common/event.rkt" + "image.rkt") +(unsafe!) +(objc-unsafe!) + +(provide button% + MyButton) + +;; ---------------------------------------- + +(import-class NSButton NSView NSImageView) + +(define-objc-class MyButton NSButton + #:mixins (FocusResponder) + [wx] + (-a _void (clicked: [_id sender]) + (queue-window-event wx (lambda () (send wx clicked))))) + +(defclass button% item% + (init parent cb label x y w h style font + [button-type #f]) + (init-field [event-type 'button]) + (inherit get-cocoa get-cocoa-window init-font) + + (define button-cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyButton alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + (make-NSSize w h))))]) + (when button-type + (tellv cocoa setButtonType: #:type _int button-type)) + (unless button-type + (tellv cocoa setBezelStyle: #:type _int (if (not (string? label)) + NSRegularSquareBezelStyle + NSRoundedBezelStyle))) + (cond + [(string? label) + (tellv cocoa setTitle: #:type _NSString label)] + [(send label ok?) + (if button-type + (tellv cocoa setTitle: #:type _NSString "") + (tellv cocoa setImage: (bitmap->image label)))] + [else + (tellv cocoa setTitle: #:type _NSString "")]) + (init-font cocoa font) + (tellv cocoa sizeToFit) + cocoa)) + + (define cocoa (if (and button-type + (not (string? label)) + (send label ok?)) + ;; Check-box image: need an view to join a button and an image view: + ;; (Could we use the NSImageButtonCell from the radio-box implementation + ;; instead?) + (let* ([frame (tell #:type _NSRect button-cocoa frame)] + [new-width (+ (NSSize-width (NSRect-size frame)) + (send label get-width))] + [new-height (max (NSSize-height (NSRect-size frame)) + (send label get-height))]) + (let ([cocoa (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height)))] + [image-cocoa (as-objc-allocation + (tell (tell NSImageView alloc) init))]) + (tellv cocoa addSubview: button-cocoa) + (tellv cocoa addSubview: image-cocoa) + (tellv image-cocoa setImage: (bitmap->image label)) + (tellv image-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) + (quotient (- new-height + (send label get-height)) + 2)) + (make-NSSize (send label get-width) + (send label get-height)))) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize new-width new-height))) + (set-ivar! button-cocoa wx this) + cocoa)) + button-cocoa)) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)]) + + (when (memq 'border style) + (tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell))) + + (tellv button-cocoa setTarget: button-cocoa) + (tellv button-cocoa setAction: #:type _SEL (selector clicked:)) + + (define/override (get-cocoa-control) button-cocoa) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)]))) + + (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt new file mode 100644 index 00000000..2fb3d1c3 --- /dev/null +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -0,0 +1,345 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + racket/draw + racket/draw/color + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "dc.rkt" + "../common/event.rkt" + "../common/queue.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "freeze.rkt") + +(provide canvas%) + +;; ---------------------------------------- + +(import-class NSView NSGraphicsContext NSScroller) + +(define-objc-class MyView NSView + #:mixins (FocusResponder KeyMouseResponder) + [wx] + (-a _void (drawRect: [_NSRect r]) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState)))) + (send wx refresh)) + (-a _void (viewWillMoveToWindow: [_id w]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc))))) + (-a _void (onHScroll: [_id scroller]) + (when wx (send wx do-scroll 'horizontal scroller))) + (-a _void (onVScroll: [_id scroller]) + (when wx (send wx do-scroll 'vertical scroller)))) + +(define-struct scroller (cocoa [range #:mutable] [page #:mutable])) +(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) + +(define canvas% + (class window% + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-cocoa + make-graphics-context + get-client-size + is-shown-to-root? + move get-x get-y + on-size) + + (define vscroll-ok? (and (memq 'vscroll style) #t)) + (define vscroll? vscroll-ok?) + (define hscroll-ok? (and (memq 'hscroll style) #t)) + (define hscroll? hscroll-ok?) + + (define canvas-style style) + + (define paint-queued? #f) + (define/override (refresh) + ;; can be called from any thread, including the event-pump thread + (unless paint-queued? + (set! paint-queued? #t) + (queue-window-event this (lambda () + (set! paint-queued? #f) + (on-paint))))) + + (define/override (get-cocoa-content) content-cocoa) + + (super-new + [parent parent] + [cocoa + (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + (make-NSSize w h))))] + [no-show? (memq 'deleted style)]) + + (define cocoa (get-cocoa)) + + (define content-cocoa + (as-objc-allocation + (tell (tell MyView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))))) + (tell #:type _void cocoa addSubview: content-cocoa) + (set-ivar! content-cocoa wx this) + + (define dc (make-object dc% (make-graphics-context) 0 0 10 10)) + + (refresh) + + (define/public (get-dc) dc) + + (define/public (fix-dc) + (let ([p (tell #:type _NSPoint content-cocoa + convertPoint: #:type _NSPoint (make-NSPoint 0 0) + toView: #f)] + [xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox yb)))) + + (define/public (on-paint) (void)) + + (define/override (set-size x y w h) + (do-set-size x y w h)) + + (define/private (do-set-size x y w h) + (super set-size x y w h) + (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0)) + (- h (if hscroll? scroll-width 0)))] + [pos (make-NSPoint 0 (if hscroll? scroll-width 0))]) + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))) + (when v-scroller + (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint (- w scroll-width) + (if hscroll? + scroll-width + 0)) + (make-NSSize scroll-width + (- h (if hscroll? scroll-width 0)))))) + (when h-scroller + (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (- w (if vscroll? scroll-width 0)) + scroll-width)))) + (fix-dc) + (on-size 0 0)) + (define/override (client-y-offset) + (if hscroll? + scroll-width + 0)) + + (define/public (show-scrollbars h? v?) + (let ([h? (and h? hscroll-ok?)] + [v? (and v? vscroll-ok?)]) + (unless (and (eq? h? hscroll?) + (eq? v? vscroll?)) + (cond + [(and h? (not hscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] + [(and hscroll? (not h?)) + (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) + (set! hscroll? h?) + (cond + [(and v? (not vscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] + [(and vscroll? (not v?)) + (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) + (set! vscroll? v?) + (let ([r (tell #:type _NSRect cocoa frame)]) + (do-set-size (NSPoint-x (NSRect-origin r)) + (NSPoint-y (NSRect-origin r)) + (NSSize-width (NSRect-size r)) + (NSSize-height (NSRect-size r))))))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + + (define (update which scroll- v) + (if (eq? which 'vertical) + (scroll- v-scroller v) + (scroll- h-scroller v))) + + (define/public (set-scroll-page which v) + (update which scroll-page v)) + (define/public (set-scroll-range which v) + (update which scroll-range v)) + (define/public (set-scroll-pos which v) + (update which scroll-pos v)) + + (define/public (get-scroll-page which) + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-range which) + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-pos which) + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) + + (define v-scroller + (and vscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint (- w scroll-width) + (if hscroll? + scroll-width + 0)) + (make-NSSize scroll-width + (max (- h (if hscroll? scroll-width 0)) + (+ scroll-width 10)))))) + 1 + 1))) + (define h-scroller + (and hscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (max (- w (if vscroll? scroll-width 0)) + (+ scroll-width 10)) + scroll-width)))) + 1 + 1))) + + (when v-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) + (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) + (when h-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) + (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) + + (define scroll-pos + (case-lambda + [(scroller val) + (when scroller + (tellv (scroller-cocoa scroller) setFloatValue: + #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) + 0.0)))] + [(scroller) + (if scroller + (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) + (scroller-range scroller)))) + 0)])) + + (define scroll-range + (case-lambda + [(scroller val) + (when scroller + (let ([pos (scroll-pos scroller)] + [page (scroll-page scroller)]) + (set-scroller-range! scroller val) + (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) + (scroll-pos scroller pos) + (scroll-page scroller page)))] + [(scroller) + (if scroller + (scroller-range scroller) + 1)])) + + (define scroll-page + (case-lambda + [(scroller val) + (when scroller + (set-scroller-page! scroller val) + (tellv (scroller-cocoa scroller) setKnobProportion: + #:type _CGFloat (max (min 1.0 (/ val + (+ val (exact->inexact (scroller-range scroller))))) + 0.0)))] + [(scroller) + (if scroller + (scroller-page scroller) + 1)])) + + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) bg-col) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col)) + + (define/public (do-scroll direction scroller) + ;; Called from the Cocoa handler thread + (let ([part (tell #:type _int scroller hitPart)]) + (queue-window-event + this + (lambda () + (let ([kind + (cond + [(= part NSScrollerDecrementPage) + (set-scroll-pos direction (- (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-up] + [(= part NSScrollerIncrementPage) + (set-scroll-pos direction (+ (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-down] + [(= part NSScrollerDecrementLine) + (set-scroll-pos direction (- (get-scroll-pos direction) 1)) + 'line-up] + [(= part NSScrollerIncrementLine) + (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) + 'line-down] + [(= part NSScrollerKnob) + 'thumb] + [else #f])]) + (when kind + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)]))))))) + (frozen-stack-run-some + (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) + 200)) + (define/public (on-scroll e) (void)) + + (define/override (wants-all-events?) + ;; Called in Cocoa event-handling mode + #t) + + (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented scroll) + (def/public-unimplemented warp-pointer) + (def/public-unimplemented view-start) + (define/public (set-resize-corner on?) + (void)) + (def/public-unimplemented get-virtual-size))) diff --git a/collects/mred/private/wx/cocoa/check-box.rkt b/collects/mred/private/wx/cocoa/check-box.rkt new file mode 100644 index 00000000..7a7cacac --- /dev/null +++ b/collects/mred/private/wx/cocoa/check-box.rkt @@ -0,0 +1,25 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class + "../../syntax.rkt" + "button.rkt" + "types.rkt" + "const.rkt") +(unsafe!) +(objc-unsafe!) + +(provide check-box%) + +;; ---------------------------------------- + +(defclass check-box% button% + (inherit get-cocoa) + (super-new [button-type NSSwitchButton] + [event-type 'check-box]) + + (define/public (set-value v) + (tellv (get-cocoa) setState: #:type _NSInteger (if v 1 0))) + (define/public (get-value) + (positive? (tell #:type _NSInteger (get-cocoa) state)))) + diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt new file mode 100644 index 00000000..8d6fbbc7 --- /dev/null +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -0,0 +1,70 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt") +(unsafe!) +(objc-unsafe!) + +(provide choice%) + +;; ---------------------------------------- + +(import-class NSPopUpButton) + +(define-objc-class MyPopUpButton NSPopUpButton + #:mixins (FocusResponder) + [wx] + (-a _void (clicked: [_id sender]) + (queue-window-event wx (lambda () (send wx clicked))))) + +(defclass choice% item% + (init parent cb label + x y w h + choices style font) + (inherit get-cocoa init-font) + + (super-new [parent parent] + [cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyPopUpButton alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + (make-NSSize w h)) + pullsDown: #:type _BOOL #f))]) + (for ([lbl (in-list choices)] + [i (in-naturals)]) + (tellv cocoa + insertItemWithTitle: #:type _NSString lbl + atIndex: #:type _NSInteger i)) + (init-font cocoa font) + (tellv cocoa sizeToFit) + (tellv cocoa setTarget: cocoa) + (tellv cocoa setAction: #:type _SEL (selector clicked:)) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))) + + (define/public (set-selection i) + (tell (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) + (define/public (get-selection) + (tell #:type _NSInteger (get-cocoa) indexOfSelectedItem)) + (define/public (number) + (tell #:type _NSInteger (get-cocoa) numberOfItems)) + (define/public (clear) + (tellv (get-cocoa) removeAllItems)) + (define/public (append lbl) + (tellv (get-cocoa) + insertItemWithTitle: #:type _NSString lbl + atIndex: #:type _NSInteger (number)))) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt new file mode 100644 index 00000000..76a531e5 --- /dev/null +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -0,0 +1,12 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide clipboard-driver% + has-x-selection?) + +(define (has-x-selection?) #f) + +(defclass clipboard-driver% object% + (init x-selection?) ; always #f + (super-new)) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt new file mode 100644 index 00000000..8f607936 --- /dev/null +++ b/collects/mred/private/wx/cocoa/const.rkt @@ -0,0 +1,69 @@ +#lang scheme/base + +(provide (except-out (all-defined-out) <<)) + +(define NSTitledWindowMask 1) +(define NSBorderlessWindowMask 0) +(define NSClosableWindowMask 2) +(define NSMiniaturizableWindowMask 4) +(define NSResizableWindowMask 8) +(define NSTexturedBackgroundWindowMask 256) + +(define NSBackingStoreBuffered 2) +(define NSRoundedBezelStyle 1) +(define NSRegularSquareBezelStyle 2) + +(define NSAnyEventMask #xffffffff) + +(define (<< a b) (arithmetic-shift a b)) + +(define NSAlphaShiftKeyMask (1 . << . 16)) +(define NSShiftKeyMask (1 . << . 17)) +(define NSControlKeyMask (1 . << . 18)) +(define NSAlternateKeyMask (1 . << . 19)) +(define NSCommandKeyMask (1 . << . 20)) +(define NSNumericPadKeyMask (1 . << . 21)) +(define NSHelpKeyMask (1 . << . 22)) +(define NSFunctionKeyMask (1 . << . 23)) + +(define NSScrollerNoPart 0) +(define NSScrollerDecrementPage 1) +(define NSScrollerKnob 2) +(define NSScrollerIncrementPage 3) +(define NSScrollerDecrementLine 4) +(define NSScrollerIncrementLine 5) +(define NSScrollerKnobSlot 6) + +(define NSMomentaryLightButton 0) +(define NSPushOnPushOffButton 1) +(define NSToggleButton 2) +(define NSSwitchButton 3) +(define NSRadioButton 4) +(define NSMomentaryChangeButton 5) +(define NSOnOffButton 6) +(define NSMomentaryPushInButton 7) +(define NSMomentaryPushButton 0) +(define NSMomentaryLight 7) + +(define NSFocusRingTypeDefault 0) +(define NSFocusRingTypeNone 1) +(define NSFocusRingTypeExterior 2) + +(define kCGBitmapAlphaInfoMask #x1F) +(define kCGBitmapFloatComponents (1 . << . 8)) +(define kCGBitmapByteOrderMask #x7000) +(define kCGBitmapByteOrderDefault (0 . << . 12)) +(define kCGBitmapByteOrder16Little (1 . << . 12)) +(define kCGBitmapByteOrder32Little (2 . << . 12)) +(define kCGBitmapByteOrder16Big (3 . << . 12)) +(define kCGBitmapByteOrder32Big (4 . << . 12)) + +(define kCGImageAlphaNone 0) +(define kCGImageAlphaPremultipliedLast 1) +(define kCGImageAlphaPremultipliedFirst 2) +(define kCGImageAlphaLast 3) +(define kCGImageAlphaFirst 4) +(define kCGImageAlphaNoneSkipLast 5) +(define kCGImageAlphaNoneSkipFirst 6) + + diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt new file mode 100644 index 00000000..6854f280 --- /dev/null +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -0,0 +1,34 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class) +(unsafe!) +(objc-unsafe!) + +(provide cursor-driver%) + +(import-class NSCursor) + +(define cursor-driver% + (class object% + (define handle #f) + + (define/public (set-standard sym) + (case sym + [(arrow) + (set! handle (tell NSCursor arrowCursor))] + [(cross) + (set! handle (tell NSCursor crosshairCursor))] + [(hand) + (set! handle (tell NSCursor openHandCursor))] + [(ibeam) + (set! handle (tell NSCursor IBeamCursor))] + [(size-n/s) + (set! handle (tell NSCursor resizeUpDownCursor))] + [(size-e/w) + (set! handle (tell NSCursor resizeLeftRightCursor))])) + + (define/public (ok?) (and handle #t)) + + (super-new))) + diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt new file mode 100644 index 00000000..9f586383 --- /dev/null +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + racket/draw/cairo + racket/draw/dc + racket/draw/local + "../common/queue.rkt" + "../../syntax.rkt") + +(provide dc% + _CGContextRef + CGContextSetRGBFillColor + CGContextFillRect) + +(define _CGContextRef (_cpointer 'CGContextRef)) +(define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) +(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) +(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) +(define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) + +(define dc-backend% + (class* default-dc-backend% (dc-backend<%>) + (init context dx dy width height) + (super-new) + + (inherit reset-cr) + + (define the-context context) ;; retain as long as we need `cg' + (define cg (tell #:type _CGContextRef context graphicsPort)) + + (define old-dx 0) + (define old-dy 0) + + (define/private (set-bounds dx dy width height) + (set! old-dx dx) + (set! old-dy (+ dy height)) + (CGContextTranslateCTM cg old-dx old-dy) + (CGContextScaleCTM cg 1 -1) + (let ([surface (cairo_quartz_surface_create_for_cg_context cg width height)]) + (set! cr (cairo_create surface)) + (cairo_surface_destroy surface)) + (set! clip-width width) + (set! clip-height height) + (cairo_rectangle cr 0 0 width height) + (cairo_clip cr)) + + (define clip-width width) + (define clip-height height) + + (define/override (reset-clip cr) + (super reset-clip cr) + (cairo_rectangle cr 0 0 clip-width clip-height) + (cairo_clip cr)) + + (define cr #f) + (set-bounds dx dy width height) + + (define/public (reset-bounds dx dy width height) + (let ([old-cr cr]) + (when old-cr + (set! cr #f) + (cairo_destroy old-cr))) + (CGContextScaleCTM cg 1 -1) + (CGContextTranslateCTM cg (- old-dx) (- old-dy)) + (set-bounds dx dy width height) + (reset-cr)) + + (def/override (get-size) + (values (exact->inexact clip-width) + (exact->inexact clip-height))) + + (define/override (get-cr) cr) + + (define/override (flush-cr) + (add-event-boundary-sometimes-callback! cg CGContextFlush)))) + +(define dc% + (dc-mixin dc-backend%)) + diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt new file mode 100644 index 00000000..ea21aaf5 --- /dev/null +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -0,0 +1,31 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "../common/queue.rkt" + "frame.rkt") + +(provide dialog%) + +(defclass dialog% frame% + (super-new [is-dialog? #t]) + + (define close-sema #f) + + (define/override (direct-show on?) + (unless on? + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f))) + (super direct-show on?)) + + (define/override (show on?) + (if on? + (unless close-sema + (let ([s (make-semaphore)]) + (set! close-sema s) + (super show on?) + (yield s))) + (super show on?)))) + + + diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt new file mode 100644 index 00000000..6d128e71 --- /dev/null +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -0,0 +1,242 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "queue.rkt" + "menu-bar.rkt" + "../../syntax.rkt" + "../common/queue.rkt") +(unsafe!) +(objc-unsafe!) + +(provide frame%) + +;; ---------------------------------------- + +(import-class NSWindow NSGraphicsContext NSMenu) + +(define front #f) + +(define empty-mb (new menu-bar%)) + +(define-objc-class MyWindow NSWindow + #:mixins (FocusResponder KeyMouseResponder) + [wx] + [-a _scheme (getEventspace) + (send wx get-eventspace)] + [-a _BOOL (canBecomeKeyWindow) #t] + [-a _BOOL (canBecomeMainWindow) #t] + [-a _BOOL (windowShouldClose: [_id win]) + (queue-window-event wx (lambda () + (when (send wx on-close) + (send wx direct-show #f)))) + #f] + [-a _void (windowDidResize: [_id notification]) + (when wx + (queue-window-event wx (lambda () + (send wx on-size 0 0) + (send wx clean-up))))] + [-a _void (windowDidMove: [_id notification]) + (when wx + (queue-window-event wx (lambda () + (send wx on-size 0 0))))] + [-a _void (windowDidBecomeMain: [_id notification]) + (when wx + (set! front wx) + (queue-window-event wx (lambda () + (send wx install-mb) + (send wx on-activate #t))))] + [-a _void (windowDidResignMain: [_id notification]) + (when wx + (when (eq? front wx) (set! front #f)) + (queue-window-event wx (lambda () + (send wx on-activate #f))))]) + +(set-eventspace-hook! (lambda (w) + (and w + (if (objc-is-a? w MyWindow) + (tell #:type _scheme w getEventspace) + (and front + (send front get-eventspace)))))) + +(define (init-pos x y) + (if (and (= x -11111) + (= y -11111)) + (values 0 0) + (values x y))) + +(define frame% + (class window% + (init parent + label + x y w h + style) + (init [is-dialog? #f]) + + (inherit get-cocoa + pre-on-char pre-on-event) + + (super-new [parent #f] + [cocoa + (as-objc-allocation + (tell (tell MyWindow alloc) + initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) + (make-NSRect (make-NSPoint x y) + (make-NSSize w h))) + styleMask: #:type _int (if (memq 'no-caption style) + NSBorderlessWindowMask + (bitwise-ior + NSTitledWindowMask + (if is-dialog? + 0 + (bitwise-ior + NSClosableWindowMask + NSMiniaturizableWindowMask + (if (memq 'no-resize-border style) + 0 + NSResizableWindowMask))))) + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))] + [no-show? #t]) + (define cocoa (get-cocoa)) + (tellv cocoa setDelegate: cocoa) + + (define/override (get-cocoa-content) + (tell cocoa contentView)) + (define/override (get-cocoa-window) cocoa) + (define/override (get-wx-window) this) + + (define/override (make-graphics-context) + (as-objc-allocation + (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) + + (define/public (clean-up) + ;; When a window is resized, then any drawing that is in flight + ;; might draw outside the canvas boundaries. Just refresh everything. + (tellv cocoa display)) + + (when label + (tellv cocoa setTitle: #:type _NSString label)) + + (define/public (direct-show on?) + (if on? + (tellv cocoa makeKeyAndOrderFront: #f) + (tellv cocoa orderOut: #f)) + (register-frame-shown this on?)) + + (define/override (show on?) + (direct-show on?)) + + (define/override (is-shown?) + (tell #:type _bool cocoa isVisible)) + + (define/override (is-shown-to-root?) + (is-shown?)) + + (define/override (is-parent-enabled-to-root?) + #t) + + (define/public (flip-screen y) + (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) + (- (NSSize-height (NSRect-size f)) y))) + + (define/override (flip y h) (flip-screen (+ y h))) + + (define/override (set-size x y w h) + (unless (and (= x -1) (= y -1)) + (move x y)) + (let ([f (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect (make-NSPoint (NSPoint-x (NSRect-origin f)) + (- (NSPoint-y (NSRect-origin f)) + (- h + (NSSize-height (NSRect-size f))))) + (make-NSSize w h)) + display: #:type _BOOL #t))) + (define/override (move x y) + (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y)))) + + (define/override (center dir wrt) + (let ([f (tell #:type _NSRect cocoa frame)] + [s (tell #:type _NSRect (tell cocoa screen) frame)]) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect (make-NSPoint + (if (or (eq? dir 'both) + (eq? dir 'horizontal)) + (/ (- (NSSize-width (NSRect-size s)) + (NSSize-width (NSRect-size f))) + 2) + (NSPoint-x (NSRect-origin f))) + (if (or (eq? dir 'both) + (eq? dir 'vertical)) + (/ (- (NSSize-height (NSRect-size s)) + (NSSize-height (NSRect-size f))) + 2) + (NSPoint-x (NSRect-origin f)))) + (NSRect-size f)) + display: #:type _BOOL #t))) + + (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) + (define (adj v) (if (negative? v) 32000 v)) + (tellv cocoa setMinSize: #:type _NSSize (make-NSSize (max min-x 1) + (max min-y 1))) + (tellv cocoa setMaxSize: #:type _NSSize (make-NSSize (adj max-x) + (adj max-y))) + (tellv cocoa setResizeIncrements: #:type _NSSize (make-NSSize inc-x inc-y))) + + (define hide-mb? (and (memq 'hide-menu-bar style) #t)) + (define mb #f) + (define/public (get-menu-bar) mb) + (define/public (set-menu-bar _mb) + (set! mb _mb) + (when (tell #:type _BOOL cocoa isMainWindow) + (install-mb))) + + (define/public (install-mb) + (tellv NSMenu setMenuBarVisible: #:type _BOOL (not hide-mb?)) + (if mb + (send mb install) + (send empty-mb install))) + + (define/public (on-activate on?) (void)) + + (define/public (set-icon bm1 bm2 mode) (void)) ;; FIXME + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (def/public-unimplemented on-toolbar-click) + (def/public-unimplemented on-menu-click) + (def/public-unimplemented on-menu-command) + (def/public-unimplemented on-mdi-activate) + (def/public-unimplemented on-close) + (define/public (designate-root-frame) (void)) + (def/public-unimplemented system-menu) + + (define/public (set-modified on?) + ;; Use standardWindowButton: ... + (void)) + + (define/public (create-status-line) (void)) + (define/public (set-status-text s) (void)) + (def/public-unimplemented status-line-exists?) + + (define/public (is-maximized?) + (tell #:type _BOOL cocoa isZoomed)) + (define/public (maximize on?) + (unless (eq? (tell #:type _BOOL cocoa isZoomed) + (and on? #t)) + (tellv cocoa zoom: cocoa))) + + (def/public-unimplemented iconized?) + (def/public-unimplemented iconize) + + (define/public (set-title s) + (tellv cocoa setTitle: #:type _NSString s)))) diff --git a/collects/mred/private/wx/cocoa/freeze.rkt b/collects/mred/private/wx/cocoa/freeze.rkt new file mode 100644 index 00000000..b9ad42b4 --- /dev/null +++ b/collects/mred/private/wx/cocoa/freeze.rkt @@ -0,0 +1,44 @@ +#lang scheme/base +(require scheme/foreign + "../common/utils.rkt" + "../common/queue.rkt") +(unsafe!) + +(provide call-with-frozen-stack + frozen-stack-run-some + constrained-reply) + +(define-mz scheme_with_stack_freeze (_fun (_fun _scheme -> _int) _scheme -> _int)) +(define-mz scheme_frozen_run_some (_fun (_fun _scheme -> _int) _scheme _int -> _int)) +(define-mz scheme_is_in_frozen_stack (_fun -> _int)) + +(define (do-apply p) + ;; Continuation prompt ensures that errors do not escape + ;; (and escapes are not supported by the frozen-stack implementation) + (call-with-continuation-prompt p) + 1) + +(define (call-with-frozen-stack thunk) + (void (scheme_with_stack_freeze do-apply thunk))) + +(define (frozen-stack-run-some thunk msecs) + (positive? (scheme_frozen_run_some do-apply thunk msecs))) + +;; FIXME: this loop needs to give up on the thunk +;; if it takes too long to return; as long as we're in the +;; loop, no other threads/eventspaces can run +(define (constrained-reply es thunk default) + (if (eq? (current-thread) (eventspace-handler-thread es)) + (let ([done? #f] + [result default]) + (frozen-stack-run-some (lambda () (set! result (thunk))) + 200) + (let loop () + (frozen-stack-run-some (lambda () (set! done? #t)) 200) + (unless done? (loop))) + result) + (begin + (fprintf (current-error-port) "WARNING: internal error: wrong eventspace for constrained event handling\n") + default))) + + diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt new file mode 100644 index 00000000..adcbde13 --- /dev/null +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -0,0 +1,61 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt") +(unsafe!) +(objc-unsafe!) + +(provide gauge%) + +;; ---------------------------------------- + +(import-class NSProgressIndicator) + +(define-objc-class MyProgressIndicator NSProgressIndicator + #:mixins () + [wx]) + +(defclass gauge% item% + (init parent + label + rng + x y w h + style + font) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa (let ([cocoa (tell (tell MyProgressIndicator alloc) init)]) + (tellv cocoa setIndeterminate: #:type _BOOL #f) + (tellv cocoa setMaxValue: #:type _double* rng) + (tellv cocoa setDoubleValue: #:type _double* 0.0) + #; + (tellv cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (if vert? 24 32) + (if vert? 32 24)))) + (tellv cocoa sizeToFit) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define cocoa (get-cocoa)) + + (define/override (enable on?) (void)) + (define/override (is-window-enabled?) #t) + + (define/public (get-range) + (inexact->exact (floor (tell #:type _double cocoa maxValue)))) + (define/public (set-range rng) + (tellv cocoa setMaxValue: #:type _double* rng)) + + (define/public (set-value v) + (tellv cocoa setDoubleValue: #:type _double* v)) + (define/public (get-value) + (min (inexact->exact (floor (tell #:type _double cocoa doubleValue))) + (get-range)))) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt new file mode 100644 index 00000000..ef1c4200 --- /dev/null +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -0,0 +1,38 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "panel.rkt") +(unsafe!) +(objc-unsafe!) + +(provide group-panel%) + +(import-class NSBox) + +(defclass group-panel% (panel-mixin window%) + (init parent + x y w h + style + label) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa + (let ([cocoa (as-objc-allocation + (tell (tell NSBox alloc) init))]) + (when label + (tellv cocoa setTitle: #:type _NSString label) + (tellv cocoa sizeToFit)) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define/override (get-cocoa-content) + (tell (get-cocoa) contentView)) + + (define/public (set-label l) + (tellv (get-cocoa) setTitle: #:type _NSString l))) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt new file mode 100644 index 00000000..d43e1951 --- /dev/null +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + "../common/bstr.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "../../lock.rkt" + (only-in '#%foreign ffi-callback)) + +(provide bitmap->image) + +(import-class NSImage) + +(define _CGImageRef (_cpointer 'CGImageRef)) +(define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef)) +(define _CGDataProviderRef (_cpointer 'GCDataProviderRef)) + +(define _size_t _long) +(define _off_t _long) + +(define-appserv CGColorSpaceCreateDeviceRGB (_fun -> _CGColorSpaceRef)) +(define-appserv CGColorSpaceRelease (_fun _CGColorSpaceRef -> _void)) + +(define-appserv CGImageCreate (_fun _size_t ; w + _size_t ; h + _size_t ; bitsPerComponent + _size_t ; bitsPerPixel + _size_t ; bytesPerRow + _CGColorSpaceRef ; colorspace + _int ; bitmapInfo + _CGDataProviderRef ; provider + _pointer ; CGFloat decode[] + _bool ; shouldInterpolate + _int ; intent + -> _CGImageRef)) + +(define free-it + (ffi-callback free (list _pointer) _void #f #t)) + +(define-appserv CGDataProviderCreateWithData (_fun _pointer _pointer _size_t _fpointer + -> _CGDataProviderRef)) +(define-appserv CGDataProviderRelease (_fun _CGDataProviderRef -> _void)) + +(define (get-image-bytes info) + info) +(define (release-image-bytes info bytes) + (void)) +(define (get-bytes-at-position bytes dest-bytes start count) + (memcpy dest-bytes (ptr-add bytes start) count)) +(define (release-info info) + (free info)) + +(define (bitmap->image bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [str (make-bytes (* w h 4) 255)]) + (send bm get-argb-pixels 0 0 w h str #f) + (let ([mask-bm (send bm get-loaded-mask)]) + (when mask-bm + (send mask-bm get-argb-pixels 0 0 w h str #t))) + (as-entry + (lambda () + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4)) (* w h 4) 1)]) + (memcpy rgba str (sub1 (* w h 4))) + (let* ([cs (CGColorSpaceCreateDeviceRGB)] + [provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)] + [image (CGImageCreate w + h + 8 + 32 + (* 4 w) + cs + (bitwise-ior kCGImageAlphaFirst + kCGBitmapByteOrder32Big) + provider ; frees `rgba' + #f + #f + 0)]) + (CGDataProviderRelease provider) + (CGColorSpaceRelease cs) + (tell (tell NSImage alloc) + initWithCGImage: #:type _CGImageRef image + size: #:type _NSSize (make-NSSize w h)))))))) diff --git a/collects/mred/private/wx/cocoa/init.rkt b/collects/mred/private/wx/cocoa/init.rkt new file mode 100644 index 00000000..2c3b5fba --- /dev/null +++ b/collects/mred/private/wx/cocoa/init.rkt @@ -0,0 +1,6 @@ +#lang scheme/base +(require "pool.rkt" + "queue.rkt") + +(define pump-thread (cocoa-start-event-pump)) +(cocoa-install-event-wakeup) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt new file mode 100644 index 00000000..bcc15110 --- /dev/null +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -0,0 +1,37 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "window.rkt" + "const.rkt" + "types.rkt") +(unsafe!) +(objc-unsafe!) + +(provide item%) + +(import-class NSFont) +(define sys-font (tell NSFont + systemFontOfSize: #:type _CGFloat 13)) + +(defclass item% window% + (inherit get-cocoa) + + (define/public (get-cocoa-control) (get-cocoa)) + + (define/override (enable on?) + (tellv (get-cocoa) setEnabled: #:type _BOOL on?)) + (define/override (is-window-enabled?) + (tell #:type _BOOL (get-cocoa-control) isEnabled)) + + (define/override (gets-focus?) + (tell #:type _BOOL (get-cocoa) canBecomeKeyView)) + + (def/public-unimplemented set-label) + (def/public-unimplemented get-label) + (def/public-unimplemented command) + (super-new) + + (define/public (init-font cocoa font) + (tellv cocoa setFont: sys-font))) diff --git a/collects/mred/private/wx/cocoa/keycode.rkt b/collects/mred/private/wx/cocoa/keycode.rkt new file mode 100644 index 00000000..572d1f2c --- /dev/null +++ b/collects/mred/private/wx/cocoa/keycode.rkt @@ -0,0 +1,56 @@ +#lang scheme/base + +(provide map-key-code) + +(define (map-key-code v) + (hash-ref + #hash((122 . f1) + (120 . f2) + (99 . f3) + (118 . f4) + (96 . f5) + (97 . f6) + (98 . f7) + (100 . f8) + (101 . f9) + (109 . f10) + (103 . f11) + (111 . f12) + (105 . f13) + (107 . f14) + (113 . f15) + (#x35 . escape) + (#x7e . up) + (#x7d . down) + (#x3d . down) + (#x7b . left) + (#x3b . left) + (#x7c . right) + (#x3c . right) + (#x24 . #\return) + (#x30 . #\tab) + (#x33 . #\backspace) + (#x75 . #\rubout) + (#x73 . home) + (#x77 . end) + (#x74 . prior) + (#x79 . next) + (#x45 . add) + (78 . subtract) + (#x43 . multiply) + (#x4b . divide) + (71 . separator) + (65 . decimal) + (76 . #\u3) ; numpad enter + (82 . numpad0) + (83 . numpad1) + (84 . numpad2) + (85 . numpad3) + (86 . numpad4) + (87 . numpad5) + (88 . numpad6) + (89 . numpad7) + (91 . numpad8) + (92 . numpad9)) + v + #f)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt new file mode 100644 index 00000000..aa3115e3 --- /dev/null +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -0,0 +1,188 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class + (only-in scheme/list take drop) + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "window.rkt" + "../common/event.rkt") +(unsafe!) +(objc-unsafe!) + +(provide list-box%) + +;; ---------------------------------------- + +(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet) +(import-protocol NSTableViewDataSource) + +(define-objc-class MyTableView NSTableView + [wx] + [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) + (tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))] + [-a _void (doubleClicked: [_id sender]) + (queue-window-event wx (lambda () (send wx clicked 'list-box-dclick)))] + [-a _void (tableViewSelectionDidChange: [_id aNotification]) + (queue-window-event wx (lambda () (send wx clicked 'list-box)))]) + +(define-objc-class MyDataSource NSObject + #:protocols (NSTableViewDataSource) + [wx] + [-a _NSInteger (numberOfRowsInTableView: [_id view]) + (send wx number)] + [-a _NSString (tableView: [_id aTableView] + objectValueForTableColumn: [_id aTableColumn] + row: [_NSInteger rowIndex]) + (send wx get-row rowIndex)]) + +(define (remove-nth data i) + (cond + [(zero? i) (cdr data)] + [else (cons (car data) (remove-nth (cdr data) (sub1 i)))])) + +(defclass list-box% item% + (init parent cb + label kind x y w h + choices style + font label-font) + (inherit set-size init-font) + + (define source (as-objc-allocation + (tell (tell MyDataSource alloc) init))) + (set-ivar! source wx this) + + (define items choices) + (define data (map (lambda (x) (box #f)) choices)) + (define count (length choices)) + + (define cocoa (as-objc-allocation + (tell (tell NSScrollView alloc) init))) + (define content-cocoa (let ([content-cocoa + (as-objc-allocation + (tell (tell MyTableView alloc) init))]) + (tellv content-cocoa setDelegate: content-cocoa) + (tellv content-cocoa setDataSource: source) + (tellv content-cocoa addTableColumn: + (as-objc-allocation + (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))) + (init-font content-cocoa font) + content-cocoa)) + (set-ivar! content-cocoa wx this) + + (tellv cocoa setDocumentView: content-cocoa) + (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) + (tellv content-cocoa setHeaderView: #f) + (unless (eq? kind 'single) + (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t)) + + (define/override (get-cocoa-content) content-cocoa) + (define/override (get-cocoa-control) content-cocoa) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)]) + + (set-size 0 0 32 50) + ; (tellv content-cocoa sizeToFit) + + (tellv content-cocoa setTarget: content-cocoa) + (tellv content-cocoa setDoubleAction: #:type _SEL (selector doubleClicked:)) + + (def/public-unimplemented get-label-font) + + (define/public (get-selection) + (tell #:type _NSInteger content-cocoa selectedRow)) + (define/public (get-selections) + (as-entry + (lambda () + (with-autorelease + (let ([v (tell content-cocoa selectedRowIndexes)]) + (begin0 + (let loop ([i (tell #:type _NSInteger v firstIndex)]) + (cond + [(= i NSNotFound) null] + [else (cons i (loop (tell #:type _NSInteger v + indexGreaterThanIndex: #:type _NSInteger i)))])))))))) + + (define/private (visible-range) + (tell #:type _NSRange content-cocoa + rowsInRect: #:type _NSRect (tell #:type _NSRect cocoa documentVisibleRect))) + + (define/public (get-first-item) + (NSRange-location (visible-range))) + (define/public (number-of-visible-items) + (NSRange-length (visible-range))) + (define/public (set-first-visible-item i) + ;; FIXME: visble doesn't mean at top: + (tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) + + (define/public (set-string i s) + (append (take items i) + (list s) + (drop items (add1 i))) + (reset)) + + (define/public (number) + ;; Can be called by event-handling thread + count) + (define/public (get-row n) + ;; Can be called by event-handling thread + (list-ref items n)) + + (define callback cb) + (define/public (clicked event-type) + (unless (zero? count) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)])))) + + (define/public (set-data i v) (set-box! (list-ref data i) v)) + (define/public (get-data i) (unbox (list-ref data i))) + + (define/public (selected? i) + (tell #:type _BOOL content-cocoa isRowSelected: #:type _NSInteger i)) + + (define/public (select i [on? #t] [extend? #t]) + (if on? + (as-entry + (lambda () + (with-autorelease + (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) + (tellv content-cocoa + selectRowIndexes: index + byExtendingSelection: #:type _BOOL extend?))))) + (tellv content-cocoa deselectRow: #:type _NSInteger i))) + (define/public (set-selection i) + (select i #t #f)) + + (define/public (delete i) + (set! count (sub1 count)) + (set! items (remove-nth items i)) + (set! data (remove-nth data i)) + (reset)) + (define/public (clear) + (set! count 0) + (set! items null) + (set! data null) + (reset)) + (define/public (set choices) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (set! count (length choices)) + (reset)) + + (public [append* append]) + (define (append* s [v #f]) + (set! count (add1 count)) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (reset)) + + (define/public (reset) + (tellv content-cocoa noteNumberOfRowsChanged) + (tellv content-cocoa reloadData))) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt new file mode 100644 index 00000000..54360f03 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -0,0 +1,112 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "const.rkt") +(unsafe!) +(objc-unsafe!) + +(provide menu-bar%) + +(import-class NSApplication NSMenu NSMenuItem NSProcessInfo) + +(define-cf CFBundleGetMainBundle (_fun -> _pointer)) +(define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) + +(define app-name + (or + (let ([dict (CFBundleGetInfoDictionary (CFBundleGetMainBundle))]) + (and dict + (let ([appName (tell dict objectForKey: #:type _NSString "CFBundleName")] + [alt (lambda () + (tell #:type _NSString (tell NSProcessInfo processInfo) processName))]) + (if (not appName) + (alt) + (let ([appName (cast appName _id _NSString)]) + (if (equal? appName "") + (alt) + appName)))))) + "MrEd")) + +(define cocoa-mb (tell (tell NSMenu alloc) init)) + +;; Init menu bar +(let ([app (tell NSApplication sharedApplication)] + [add-one (lambda (mb menu) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString "" + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (tellv item setSubmenu: menu) + (tellv mb addItem: item) + (tellv item release)))]) + (let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")]) + (let ([std (lambda (title sel [shortcut ""] [mods #f]) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString title + action: #:type _SEL sel + keyEquivalent: #:type _NSString shortcut)]) + (when mods + (tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods)) + (tellv item setTarget: app) + (tellv apple addItem: item) + (tellv item release)))]) + (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) + (std "Preferences..." #f) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) + (tellv app setServicesMenu: services) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString "Services" + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (tellv item setSubmenu: services) + (tellv apple addItem: item) + (tellv item release))) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (std (format "Hide ~a" app-name) (selector hide:) "h") + (std "Hide Others" (selector hideOtherApplications:) "h" (bitwise-ior + NSAlternateKeyMask + NSCommandKeyMask)) + (std "Show All" (selector unhideAllApplications:)) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (std (format "Quit ~a" app-name) (selector terminate:) "q")) + (add-one cocoa-mb apple) + (tellv app setAppleMenu: apple) + (tellv apple release) + (tellv app setMainMenu: cocoa-mb))) + +(defclass menu-bar% object% + (define menus null) + + (def/public-unimplemented set-label-top) + (def/public-unimplemented number) + (def/public-unimplemented enable-top) + + (define/public (delete which pos) + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + pos))])))) + + (public [append-menu append]) + (define (append-menu menu title) + (set! menus (append menus (list (cons menu title))))) + + (define/public (install) + (let loop () + (when ((tell #:type _NSInteger cocoa-mb numberOfItems) . > . 1) + (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) + (loop))) + (for-each (lambda (menu) + (send (car menu) install cocoa-mb (cdr menu))) + menus)) + + (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt new file mode 100644 index 00000000..932cf207 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -0,0 +1,26 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) +(objc-unsafe!) + +(provide menu-item%) + +(import-class NSMenuItem) + +(defclass menu-item% object% + (define/public (id) this) + + (define/public (install menu label) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (tellv menu addItem: item) + (tellv item release))) + + (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt new file mode 100644 index 00000000..394e3763 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -0,0 +1,108 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) +(objc-unsafe!) + +(provide menu%) + +(import-class NSMenu NSMenuItem) + +(define-struct mitem (item + [label #:mutable] + [checked? #:mutable] + [enabled? #:mutable])) + +(defclass menu% object% + (init-field label + callback + font) + + (super-new) + + (define items null) + + (define cocoa #f) + (define cocoa-menu #f) + + (define/public (install cocoa-parent label) + (unless cocoa + (set! cocoa + (as-objc-allocation + (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString label + action: #:type _SEL #f + keyEquivalent: #:type _NSString ""))) + (set! cocoa-menu + (as-objc-allocation + (tell (tell NSMenu alloc) + initWithTitle: #:type _NSString label))) + (tellv cocoa setSubmenu: cocoa-menu) + (for-each (lambda (item) + (if item + (send (mitem-item item) install cocoa-menu (mitem-label item)) + (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) + items)) + (tellv cocoa-parent addItem: cocoa)) + + (public [append-item append]) + (define (append-item i label help-str chckable?) + (set! items (append items (list (make-mitem i label #f #f)))) + (when cocoa-menu + (send i install cocoa-menu label))) + + (define/public (append-separator) + (set! items (append items (list #f))) + (when cocoa-menu + (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) + + (def/public-unimplemented select) + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + + (def/public-unimplemented set-help-string) + (def/public-unimplemented number) + + (define/private (find-pos item) + (for/or ([i (in-list items)] + [pos (in-naturals)]) + (and i + (eq? (mitem-item i) item) + pos))) + + (define/public (adjust item cocoa-cb cb) + (let ([pos (find-pos item)]) + (when pos + (when cocoa-menu + (cocoa-cb (tell cocoa-menu itemAtIndex: #:type _NSInteger pos))) + (cb (list-ref items pos))))) + + (define/public (set-label item label) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setTitle: #:type _NSString label)) + (lambda (mitem) + (set-mitem-label! mitem label)))) + + (define/public (check item on?) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setState: #:type _int (if on? 1 0))) + (lambda (mitem) + (set-mitem-checked?! mitem (and on? #t))))) + + (define/public (enable item on?) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setEnabled: #:type _BOOL on?)) + (lambda (mitem) + (set-mitem-enabled?! mitem (and on? #t))))) + + (def/public-unimplemented checked?) + (def/public-unimplemented delete-by-position) + (def/public-unimplemented delete)) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt new file mode 100644 index 00000000..bca6680f --- /dev/null +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -0,0 +1,59 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "image.rkt") +(unsafe!) +(objc-unsafe!) + +(provide message%) + +;; ---------------------------------------- + +(import-class NSTextField NSImageView) + +(defclass message% item% + (init parent label + x y + style font) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa (let* ([label (cond + [(string? label) label] + [(symbol? label) (format "<~a>" label)] + [(send label ok?) label] + [else ""])] + [cocoa + (if (string? label) + (as-objc-allocation + (tell (tell NSTextField alloc) init)) + (as-objc-allocation + (tell (tell NSImageView alloc) init)))]) + (cond + [(string? label) + (tellv cocoa setSelectable: #:type _BOOL #f) + (tellv cocoa setEditable: #:type _BOOL #f) + (tellv cocoa setBordered: #:type _BOOL #f) + (tellv cocoa setDrawsBackground: #:type _BOOL #f) + (tellv cocoa setTitleWithMnemonic: #:type _NSString label) + (tellv cocoa sizeToFit)] + [else + (tellv cocoa setImage: (bitmap->image label)) + (tellv cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize (send label get-width) + (send label get-height))))]) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define/override (set-label label) + (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)) + + (define/override (gets-focus?) #f) + + (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt new file mode 100644 index 00000000..881da5eb --- /dev/null +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -0,0 +1,42 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt") +(unsafe!) +(objc-unsafe!) + +(provide panel% + panel-mixin) + +(import-class NSView) + +(define (panel-mixin %) + (class % + (define lbl-pos 'vertical) + (super-new) + + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (def/public-unimplemented on-paint) + (define/public (set-item-cursor x y) (void)) + (def/public-unimplemented get-item-cursor))) + +(defclass panel% (panel-mixin window%) + (init parent + x y w h + style + label) + + (super-new [parent parent] + [cocoa + (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + (make-NSSize w h))))] + [no-show? (memq 'deleted style)])) + diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt new file mode 100644 index 00000000..5e94474f --- /dev/null +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -0,0 +1,108 @@ +#lang racket/base +(require "init.rkt" + "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "gl-context.rkt" + "group-box.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-group.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide platform-values) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + gl-context% + group-box% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-group% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + begin-busy-cursor + is-busy? + end-busy-cursor + has-x-selection? + hide-cursor + bell + display-size + display-origin + get-resource + write-resource + flush-display + fill-private-color + cancel-quit + get-control-font-size + key-symbol-to-integer + draw-tab-base + draw-tab + set-combo-box-font + get-double-click-time + run-printout + end-refresh-sequence + begin-refresh-sequence + file-creator-and-type + send-event + set-executer + set-dialogs + location->window + set-menu-tester + in-atomic-region + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + get-top-level-windows + find-graphical-system-path + check-for-break + play-sound + get-panel-background + get-font-from-user + get-color-from-user + application-pref-handler + application-about-handler + application-quit-handler + application-file-handler + special-option-key + special-control-key)) diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt new file mode 100644 index 00000000..4f021023 --- /dev/null +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + "utils.rkt" + "const.rkt" + "types.rkt") +(unsafe!) +(objc-unsafe!) + +(provide pool) + +(import-class NSAutoreleasePool) + +(define pool (tell (tell NSAutoreleasePool alloc) init)) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt new file mode 100644 index 00000000..38819ef7 --- /dev/null +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require racket/class + racket/draw/dc) + +(provide printer-dc%) + +(define dc-backend% + (class default-dc-backend% + (init [parent #f]) + + (super-new))) + +(define printer-dc% + (dc-mixin dc-backend%)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt new file mode 100644 index 00000000..3567a33b --- /dev/null +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -0,0 +1,130 @@ +#lang racket/base +(require "../../syntax.rkt" + racket/class + racket/draw + ffi/unsafe + ffi/unsafe/objc + "types.rkt" + "../../lock.rkt" + "../common/handlers.rkt") + +(provide + special-control-key + special-option-key + application-file-handler + application-quit-handler + application-about-handler + application-pref-handler + get-color-from-user + get-font-from-user + get-panel-background + play-sound + check-for-break + find-graphical-system-path + get-top-level-windows + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + in-atomic-region + set-menu-tester + location->window + set-dialogs + set-executer + send-event + file-creator-and-type + begin-refresh-sequence + end-refresh-sequence + run-printout + get-double-click-time + set-combo-box-font + draw-tab + draw-tab-base + key-symbol-to-integer + get-control-font-size + cancel-quit + fill-private-color + flush-display + write-resource + get-resource + display-origin + display-size + bell + hide-cursor + end-busy-cursor + is-busy? + begin-busy-cursor + get-display-depth + is-color-display? + file-selector + id-to-menu-item + get-the-x-selection + get-the-clipboard + show-print-setup + can-show-print-setup?) + +(import-class NSScreen NSCursor) + + +(define-unimplemented special-control-key) +(define-unimplemented special-option-key) +(define-unimplemented get-color-from-user) +(define-unimplemented get-font-from-user) +(define (get-panel-background) (make-object color% "gray")) +(define-unimplemented play-sound) +(define-unimplemented check-for-break) +(define-unimplemented find-graphical-system-path) +(define-unimplemented get-top-level-windows) +(define (register-collecting-blit . args) (void)) +(define (unregister-collecting-blit . args) (void)) +(define (shortcut-visible-in-label? [x #f]) #f) +(define-unimplemented in-atomic-region) +(define (set-menu-tester proc) + (void)) +(define-unimplemented location->window) +(define (set-dialogs . args) + (void)) +(define (set-executer proc) + (void)) +(define-unimplemented send-event) +(define-unimplemented file-creator-and-type) +(define (begin-refresh-sequence) (void)) +(define (end-refresh-sequence) (void)) +(define-unimplemented run-printout) +(define (get-double-click-time) + 500) +(define (set-combo-box-font f) (void)) +(define-unimplemented draw-tab) +(define-unimplemented draw-tab-base) +(define-unimplemented key-symbol-to-integer) +(define (get-control-font-size) 14) +(define-unimplemented cancel-quit) +(define-unimplemented fill-private-color) +(define (flush-display) (void)) +(define-unimplemented write-resource) +(define-unimplemented get-resource) + +(define (display-origin xb yb all?) + (set-box! xb 0) + (set-box! yb 0)) +(define (display-size xb yb v) + (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (set-box! xb (->long (NSSize-width (NSRect-size f)))) + (set-box! yb (->long (NSSize-height (NSRect-size f)))))) + +(define-unimplemented bell) +(define (hide-cursor) + (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) + +(define busy-count 0) +(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count))))) +(define (is-busy?) (positive? busy-count)) +(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) + +(define (get-display-depth) 32) +(define-unimplemented is-color-display?) +(define-unimplemented file-selector) +(define-unimplemented id-to-menu-item) +(define-unimplemented get-the-x-selection) +(define-unimplemented get-the-clipboard) +(define-unimplemented show-print-setup) +(define (can-show-print-setup?) #t) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt new file mode 100644 index 00000000..b2ecb480 --- /dev/null +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -0,0 +1,206 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "../common/queue.rkt" + "../../lock.rkt" + "freeze.rkt") +(unsafe!) +(objc-unsafe!) + +(provide app + cocoa-start-event-pump + cocoa-install-event-wakeup + queue-event + set-eventspace-hook! + + ;; from common/queue: + current-eventspace + queue-event + yield) + +(import-class NSApplication NSAutoreleasePool) +(import-protocol NSApplicationDelegate) + +(define app (tell NSApplication sharedApplication)) + +(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) + [] + [-a _BOOL (applicationShouldTerminate: [_id app]) + (queue-quit-event) + #t]) + +(tellv app finishLaunching) + +(tellv app setDelegate: (tell (tell MyApplicationDelegate alloc) init)) +(tellv app activateIgnoringOtherApps: #:type _BOOL #t) + +;; ------------------------------------------------------------ +;; Create an event to post when MzScheme has been sleeping but is +;; ready to wake up + +(import-class NSEvent) +(define NSApplicationDefined 15) +(define wake-evt + (tell NSEvent + otherEventWithType: #:type _int NSApplicationDefined + location: #:type _NSPoint-pointer (make-NSPoint 0.0 0.0) + modifierFlags: #:type _NSUInteger 0 + timestamp: #:type _double 0.0 + windowNumber: #:type _NSUInteger 0 + context: #:type _pointer #f + subtype: #:type _short 0 + data1: #:type _NSInteger 0 + data2: #:type _NSInteger 0)) +(define (post-dummy-event) + (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES)) + +;; This callback will be invoked by the CoreFoundation run loop +;; when data is available on `ready_sock', which is used to indicate +;; that MzScheme would like to wake up (and posting a Cocoa event +;; causes the event-getting function to unblock). +(define (socket_callback) + (read2 ready_sock read-buf 1) + (post-dummy-event)) + +;; ------------------------------------------------------------ +;; Create a pipe's pair of file descriptors, used to communicate +;; from the MzScheme-sleep thread to the CoreFoundation run loop. + +(define pipe2 (get-ffi-obj 'pipe #f (_fun _pointer -> _int))) +(define write2 (get-ffi-obj 'write #f (_fun _int _pointer _long -> _long))) +(define read2 (get-ffi-obj 'read #f (_fun _int _pointer _long -> _long))) +(define read-buf (make-bytes 1)) +(define-values (ready_sock write_sock) + (let ([s (malloc 'raw 2 _int)]) + (unless (zero? (pipe2 s)) + (error "pipe didn't create fds")) + (let ([r (ptr-ref s _int 0)] + [w (ptr-ref s _int 1)]) + (free s) + (values r w)))) + +;; ------------------------------------------------------------ +;; Register the event-posting callback on `ready_sock' with +;; the CoreFoundation run loop + +(define _CFIndex _uint) +(define _CFStringRef _NSString) +(define-cstruct _CFSocketContext ([version _CFIndex] + [info _pointer] + [retain (_fun _pointer -> _pointer)] + [release (_fun _pointer -> _void)] + [copyDescription (_fun _pointer -> _CFStringRef)])) +(define (sock_retain v) #f) +(define (sock_release v) (void)) +(define (sock_copy_desc v) "sock") +(define sock-context (make-CFSocketContext 0 #f sock_retain sock_release sock_copy_desc)) + +(define _CFRunLoopRef _pointer) +(define _CFAllocatorRef _pointer) +(define _CFSocketRef _pointer) +(define _CFRunLoopSourceRef _pointer) +(define _CFSocketNativeHandle _int) +(define _CFOptionFlags _uint) +(define _CFSocketCallBack (_fun -> _void)) +(define-cf CFAllocatorGetDefault (_fun -> _pointer)) +(define-cf CFSocketCreateWithNative (_fun _CFAllocatorRef + _CFSocketNativeHandle + _CFOptionFlags + _CFSocketCallBack + _CFSocketContext-pointer + -> _CFSocketRef)) +(define-cf CFSocketCreateRunLoopSource (_fun _CFAllocatorRef + _CFSocketRef + _CFIndex + -> _CFRunLoopSourceRef)) +(define-cf CFRunLoopAddSource (_fun _CFRunLoopRef + _CFRunLoopSourceRef + _CFStringRef + -> _void)) +(define-cf kCFRunLoopDefaultMode _CFStringRef) + +(define kCFSocketReadCallBack 1) + +(import-class NSRunLoop) +(let* ([rl (tell #:type _CFRunLoopRef (tell NSRunLoop currentRunLoop) getCFRunLoop)] + [cfs (CFSocketCreateWithNative (CFAllocatorGetDefault) ready_sock kCFSocketReadCallBack + socket_callback sock-context)] + [source (CFSocketCreateRunLoopSource (CFAllocatorGetDefault) cfs 0)]) + (CFRunLoopAddSource rl source kCFRunLoopDefaultMode)) + +;; ------------------------------------------------------------ +;; Cocoa event pump + +(define-cocoa NSDefaultRunLoopMode _id) ; more specifically an _NSString, but we don't need a conversion + +(import-class NSDate) +(define distantFuture (tell NSDate distantFuture)) + +(define eventspace-hook (lambda (e) #f)) +(define (set-eventspace-hook! proc) (set! eventspace-hook proc)) + +;; Call this function only in atomic mode: +(define (check-one-event wait? dequeue?) + (pre-event-sync wait?) + (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) + (begin0 + (let ([evt (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask + untilDate: (if wait? distantFuture #f) + inMode: NSDefaultRunLoopMode + dequeue: #:type _BOOL dequeue?)]) + (and evt + (or (not dequeue?) + (let ([e (eventspace-hook (tell evt window))]) + (if e + (begin + (retain evt) + (queue-event e (lambda () + (as-entry (lambda () + (call-with-frozen-stack + (lambda () + (tellv app sendEvent: evt) + (release evt)))))))) + (tellv app sendEvent: evt))) + #t))) + (tellv pool release)))) + +;; Call this function only in atomic mode: +(define (dispatch-all-ready) + (when (check-one-event #f #t) + (dispatch-all-ready))) + +(define (cocoa-start-event-pump) + (thread (lambda () + (let loop () + (sync queue-evt) + (as-entry dispatch-all-ready) + (loop))))) + +(set-check-queue! + ;; Called through an atomic callback: + (lambda () (check-one-event #f #f))) + +;; ------------------------------------------------------------ +;; Install an alternate "sleep" function (in the PLT Scheme core) +;; that wakes up if any Cocoa event is ready. + +(define-mz scheme_start_sleeper_thread (_fun _fpointer _float _pointer _int -> _void)) +(define-mz scheme_end_sleeper_thread (_fun -> _void)) + +(define-mz scheme_sleep _pointer) + +;; Called through an atomic callback: +(define (sleep-until-event secs fds) + (scheme_start_sleeper_thread scheme_sleep secs fds write_sock) + (check-one-event #t #f) ; blocks until an event is ready + (scheme_end_sleeper_thread)) + +(define (cocoa-install-event-wakeup) + (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it + (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event + (_fun #:atomic? #t + _float _pointer -> _void)))) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt new file mode 100644 index 00000000..df2a6940 --- /dev/null +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -0,0 +1,118 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "item.rkt" + "button.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt" + "image.rkt") +(unsafe!) +(objc-unsafe!) + +(provide radio-box%) + +;; ---------------------------------------- + +(import-class NSMatrix NSButtonCell) + +(define NSRadioModeMatrix 0) + +(define-objc-class MyMatrix NSMatrix + #:mixins (FocusResponder) + [wx] + (-a _void (clicked: [_id sender]) + (queue-window-event wx (lambda () (send wx clicked))))) + +(define-objc-class MyImageButtonCell NSButtonCell + [img] + [-a _NSSize (cellSize) + (let ([s (super-tell #:type _NSSize cellSize)]) + (if img + (let ([s2 (tell #:type _NSSize img size)]) + (make-NSSize (+ (NSSize-width s) (NSSize-width s2)) + (max (NSSize-height s) (NSSize-height s2)))) + s))] + [-a _void (drawInteriorWithFrame: [_NSRect f] inView: [_id view]) + (super-tell #:type _void drawInteriorWithFrame: #:type _NSRect f inView: view) + (when img + (let ([size (tell #:type _NSSize img size)]) + (tellv img + drawInRect: #:type _NSRect (make-NSRect + (make-NSPoint + (+ (NSPoint-x (NSRect-origin f)) + (- (NSSize-width (NSRect-size f)) + (NSSize-width size))) + (+ (NSPoint-y (NSRect-origin f)) + (quotient (- (NSSize-height (NSRect-size f)) + (NSSize-height size)) + 2))) + size) + fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) size) + operation: #:type _int 1 + fraction: #:type _CGFloat 1.0)))]) + +(defclass radio-box% item% + (init parent cb label + x y w h + labels + val + style + font) + (inherit get-cocoa set-focus) + + (super-new [parent parent] + [cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyMatrix alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + (make-NSSize w h)) + mode: #:type _int NSRadioModeMatrix + cellClass: (if (andmap string? labels) + NSButtonCell + MyImageButtonCell) + numberOfRows: #:type _NSInteger (length labels) + numberOfColumns: #:type _NSInteger 1))]) + (for ([label (in-list labels)] + [i (in-naturals)]) + (let ([button (tell cocoa + cellAtRow: #:type _NSInteger i + column: #:type _NSInteger 0)]) + (if (and (not (string? label)) + (send label ok?)) + (begin + (tellv button setTitle: #:type _NSString "") + (set-ivar! button img (bitmap->image label))) + (tellv button setTitle: #:type _NSString (if (string? label) + label + ""))) + (tellv button setButtonType: #:type _int NSRadioButton))) + (tellv cocoa sizeToFit) + (tellv cocoa setTarget: cocoa) + (tellv cocoa setAction: #:type _SEL (selector clicked:)) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define count (length labels)) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))) + + (define/public (button-focus i) + (if (= i -1) + 0 + (set-focus))) + + (define/public (set-selection i) + (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger i column: #:type _NSInteger 0)) + (define/public (get-selection) + (tell #:type _NSInteger (get-cocoa) selectedRow)) + (define/public (number) count)) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt new file mode 100644 index 00000000..c287e067 --- /dev/null +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -0,0 +1,74 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt" + "../common/queue.rkt" + "../../lock.rkt" + "freeze.rkt") +(unsafe!) +(objc-unsafe!) + +(provide slider%) + +;; ---------------------------------------- + +(import-class NSSlider) + +(define-objc-class MySlider NSSlider + #:mixins (FocusResponder) + [wx] + (-a _void (changed: [_id sender]) + (queue-window-event wx (lambda () (send wx changed))) + (frozen-stack-run-some + (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) + 200))) + +(defclass slider% item% + (init parent cb + label + val lo hi + x y w + style + font) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa (let ([cocoa (tell (tell MySlider alloc) init)] + [vert? (memq 'vertical style)]) + (tellv cocoa setMinValue: #:type _double* lo) + (tellv cocoa setMaxValue: #:type _double* hi) + (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) + (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (if vert? 24 32) + (if vert? 32 24)))) + (tellv cocoa setContinuous: #:type _BOOL #t) + ; (tellv cocoa sizeToFit) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define cocoa (get-cocoa)) + + (tellv cocoa setTarget: cocoa) + (tellv cocoa setAction: #:type _SEL (selector changed:)) + + (define callback cb) + (define/public (changed) + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)]))) + + + (define/public (set-value v) + (tellv cocoa setDoubleValue: #:type _double* v)) + (define/public (get-value) + (inexact->exact (floor (tell #:type _double cocoa doubleValue))))) + diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt new file mode 100644 index 00000000..fa2f440c --- /dev/null +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -0,0 +1,55 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + ffi/objc + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "panel.rkt") +(unsafe!) +(objc-unsafe!) + +(provide tab-panel%) + +(import-class NSView NSTabView NSTabViewItem) + +(defclass tab-panel% (panel-mixin window%) + (init parent + x y w h + style + labels) + (inherit get-cocoa) + + (define cocoa (as-objc-allocation + (tell (tell NSTabView alloc) init))) + (define item-cocoas + (for/list ([lbl (in-list labels)]) + (let ([item (as-objc-allocation + (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) + (tellv item setLabel: #:type _NSString lbl) + (tellv cocoa addTabViewItem: item) + item))) + (let ([sz (tell #:type _NSSize cocoa minimumSize)]) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) sz))) + + (define content-cocoa + (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect)))) + (tell #:type _void cocoa addSubview: content-cocoa) + + (define/override (get-cocoa-content) content-cocoa) + (define/override (set-size x y w h) + (super set-size x y w h) + (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect))) + + (define/public (set-label i str) + (tellv (list-ref item-cocoas i) setLabel: #:type _NSString str)) + + (define/public (set-selection i) + (tellv cocoa selectTabViewItem: (list-ref item-cocoas i))) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt new file mode 100644 index 00000000..fed4632b --- /dev/null +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -0,0 +1,60 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + "utils.rkt") +(unsafe!) +(objc-unsafe!) + +(provide _NSInteger _NSUInteger + _CGFloat + _NSPoint _NSPoint-pointer (struct-out NSPoint) + _NSSize _NSSize-pointer (struct-out NSSize) + _NSRect _NSRect-pointer (struct-out NSRect) + _NSRange _NSRange-pointer (struct-out NSRange) + NSObject + NSString _NSString + NSNotFound) + +(define _NSInteger _long) +(define _NSUInteger _ulong) + +(define 64-bit? (= (ctype-sizeof _long) 8)) + +(define _CGFloat (make-ctype (if 64-bit? _double _float) + (lambda (v) (if (and (number? v) + (exact? v)) + (exact->inexact v) + v)) + #f)) + +(define-cstruct _NSPoint ([x _CGFloat] + [y _CGFloat])) +(define-cstruct _NSSize ([width _CGFloat] + [height _CGFloat])) + +(define-cstruct _NSRect ([origin _NSPoint][size _NSSize])) + +(define-cstruct _NSRange ([location _NSUInteger] + [length _NSUInteger])) + +(import-class NSObject NSString) + +(define strings (make-weak-hash)) +(define _NSString (make-ctype _id + (lambda (v) + (or (hash-ref strings v #f) + (let ([s (as-objc-allocation + (tell (tell NSString alloc) + initWithUTF8String: + #:type _string + v))]) + (hash-set! strings v s) + s))) + (lambda (v) + (with-autorelease + (let ([s (tell #:type _bytes v UTF8String)]) + (bytes->string/utf-8 s)))))) + +(define NSNotFound (if 64-bit? + #x7fffffffffffffff + #x7fffffff)) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt new file mode 100644 index 00000000..a4e9d377 --- /dev/null +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -0,0 +1,59 @@ +#lang scheme/base +(require ffi/unsafe/objc + ffi/unsafe + ffi/unsafe/alloc + "../common/utils.rkt") + +(provide cocoa-lib + cf-lib + define-cocoa + define-cf + define-appserv + define-mz + as-objc-allocation + retain release + with-autorelease) + +(define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) +(define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) +(define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) + +(define-syntax define-cocoa/private + (syntax-rules () + [(_ id type) + (define-cocoa/private id id type)] + [(_ id c-id type) + (define id (get-ffi-obj 'c-id cocoa-lib type))])) + +(define-syntax-rule (define-cocoa id type) + (define-cocoa/private id id type)) + +(define-syntax-rule (define-cf id type) + (define id (get-ffi-obj 'id cf-lib type))) + +(define-syntax-rule (define-appserv id type) + (define id (get-ffi-obj 'id appserv-lib type))) + +(define (objc-delete v) + (tellv v release)) + +(define objc-allocator (allocator objc-delete)) + +(define-syntax-rule (as-objc-allocation expr) + ((objc-allocator (lambda () expr)))) + +(define release ((deallocator) objc-delete)) +(define retain ((retainer release car) + (lambda (obj) + (tellv obj retain)))) + +(import-class NSAutoreleasePool) + +(define-syntax-rule (with-autorelease expr) + (call-with-autorelease (lambda () expr))) +(define (call-with-autorelease thunk) + (let ([pool (as-objc-allocation + (tell (tell NSAutoreleasePool alloc) init))]) + (begin0 + (thunk) + (release pool)))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt new file mode 100644 index 00000000..72b9b342 --- /dev/null +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -0,0 +1,325 @@ +#lang scheme/base +(require ffi/objc + scheme/foreign + scheme/class + "queue.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "keycode.rkt" + "../common/event.rkt" + "../../syntax.rkt" + "freeze.rkt") +(unsafe!) +(objc-unsafe!) + +(provide window% + queue-window-event + FocusResponder + KeyMouseResponder) + +(define-local-member-name flip-client) + +;; ---------------------------------------- + +(import-class NSArray) + +(define-objc-mixin (FocusResponder Superclass) + [wx] + [-a _BOOL (acceptsFirstResponder) + #t] + [-a _BOOL (becomeFirstResponder) + (and (super-tell becomeFirstResponder) + (queue-window-event wx (lambda () + (send wx on-set-focus))) + #t)] + [-a _BOOL (resignFirstResponder) + (and (super-tell resignFirstResponder) + (queue-window-event wx (lambda () + (send wx on-kill-focus))) + #t)]) + +(define-objc-mixin (KeyMouseResponder Superclass) + [wx] + [-a _void (mouseDown: [_id event]) + (unless (do-mouse-event wx event 'left-down #t #f #f) + (super-tell #:type _void mouseDown: event))] + [-a _void (mouseUp: [_id event]) + (unless (do-mouse-event wx event 'left-up #f #f #f) + (super-tell #:type _void mouseUp: event))] + [-a _void (mouseDragged: [_id event]) + (unless (do-mouse-event wx event 'motion #t #f #f) + (super-tell #:type _void mouseDragged: event))] + [-a _void (mouseMoved: [_id event]) + (unless (do-mouse-event wx event 'motion #f #f #f) + (super-tell #:type _void mouseMoved: event))] + [-a _void (mouseEntered: [_id event]) + (unless (do-mouse-event wx event 'enter #f #f #f) + (super-tell #:type _void mouseEntered: event))] + [-a _void (mouseExited: [_id event]) + (unless (do-mouse-event wx event 'leave #f #f #f) + (super-tell #:type _void mouseExited: event))] + [-a _void (rightMouseDown: [_id event]) + (unless (do-mouse-event wx event 'right-down #f #f #t) + (super-tell #:type _void rightMouseDown: event))] + [-a _void (rightMouseUp: [_id event]) + (unless (do-mouse-event wx event 'right-up #f #f #f) + (super-tell #:type _void rightMouseUp: event))] + [-a _void (rightMouseDragged: [_id event]) + (unless (do-mouse-event wx event 'motion #f #f #t) + (super-tell #:type _void rightMouseDragged: event))] + [-a _void (otherMouseDown: [_id event]) + (unless (do-mouse-event wx event 'middle-down #f #t #f) + (super-tell #:type _void otherMouseDown: event))] + [-a _void (otherMouseUp: [_id event]) + (unless (do-mouse-event wx event 'middle-up #f #f #f) + (super-tell #:type _void otherMouseUp: event))] + [-a _void (otherMouseDragged: [_id event]) + (unless (do-mouse-event wx event 'motion #f #t #f) + (super-tell #:type _void otherMouseDragged: event))] + + [-a _void (keyDown: [_id event]) + (unless (do-key-event wx event) + (super-tell #:type _void keyDown: event))] + [-a _void (insertText: [_NSString str]) + (queue-window-event wx (lambda () + (send wx key-event-as-string str)))]) + +(define (do-key-event wx event) + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)] + [str (tell #:type _NSString event characters)] + [k (new key-event% + [key-code (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (string-ref str 0)))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [x (NSPoint-x pos)] + [y (NSPoint-y pos)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (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 (do-mouse-event wx event kind l? m? r?) + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)] + [m (new mouse-event% + [event-type kind] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long (NSPoint-x pos))] + [y (->long (send wx flip-client (NSPoint-y pos)))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))) + +(define window% + (class object% + (init-field parent + cocoa + [no-show? #f]) + + (super-new) + + (define eventspace (if parent + (send parent get-eventspace) + (current-eventspace))) + + (set-ivar! cocoa wx this) + + (unless no-show? + (show #t)) + + (define/public (get-cocoa) cocoa) + (define/public (get-cocoa-content) cocoa) + (define/public (get-cocoa-window) (send parent get-cocoa-window)) + (define/public (get-wx-window) (send parent get-wx-window)) + + (define/public (make-graphics-context) + (and parent + (send parent make-graphics-context))) + + (define/public (get-parent) + parent) + + (define/public (get-eventspace) eventspace) + + (define/public (show on?) + (if on? + (tellv (send parent get-cocoa-content) addSubview: cocoa) + (tellv cocoa removeFromSuperview))) + + (define/public (is-shown?) + (and (tell cocoa superview) #t)) + + (define/public (is-shown-to-root?) + (and (is-shown?) + (send parent is-shown-to-root?))) + + (define enabled? #t) + (define/public (is-enabled-to-root?) + (and (is-window-enabled?) (is-parent-enabled-to-root?))) + (define/public (is-parent-enabled-to-root?) + (send parent is-enabled-to-root?)) + (define/public (is-window-enabled?) + enabled?) + (define/public (enable on?) + (set! enabled? on?)) + + (define/private (get-frame) + (let ([v (tell #:type _NSRect cocoa frame)]) + v)) + + (define/public (flip y h) + (if parent + (let ([b (tell #:type _NSRect (send parent get-cocoa-content) bounds)]) + (- (NSSize-height (NSRect-size b)) (+ y h))) + y)) + + (define/public (flip-client y) + (if (tell #:type _BOOL (get-cocoa-content) isFlipped) + y + (let ([r (tell #:type _NSRect (get-cocoa-content) bounds)]) + (- (NSSize-height (NSRect-size r)) + (- y (client-y-offset)))))) + (define/public (client-y-offset) 0) + + (define/public (get-x) + (->long (NSPoint-x (NSRect-origin (get-frame))))) + (define/public (get-y) + (let ([r (get-frame)]) + (->long (flip (NSPoint-y (NSRect-origin r)) + (NSSize-height (NSRect-size r)))))) + (define/public (get-width) + (->long (NSSize-width (NSRect-size (get-frame))))) + (define/public (get-height) + (->long (NSSize-height (NSRect-size (get-frame))))) + (define/public (get-position x y) + (let* ([r (get-frame)] + [p (NSRect-origin r)]) + (set-box! x (->long (NSPoint-x p))) + (set-box! y (->long (flip (NSPoint-y p) (NSSize-height (NSRect-size r))))))) + (define/public (get-size w h) + (let ([s (NSRect-size (get-frame))]) + (set-box! w (->long (NSSize-width s))) + (set-box! h (->long (NSSize-height s))))) + + (define/public (get-client-size w h) + (let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))]) + (set-box! w (->long (NSSize-width s))) + (set-box! h (->long (NSSize-height s))))) + + (define/public (set-size x y w h) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) + (make-NSSize w h)))) + (define/public (move x y) + (set-size x y (get-width) (get-height))) + + (define/public (drag-accept-files on?) + (void)) + + (define/public (set-focus) + (let ([w (tell cocoa window)]) + (when w + (tellv w makeFirstResponder: cocoa)))) + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + + (define/public (wants-all-events?) + ;; Called in Cocoa event-handling mode + #f) + + (define/public (dispatch-on-char e just-pre?) + (cond + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when enabled? (on-char e)) #t])) + (define/public (dispatch-on-event e just-pre?) + (cond + [(call-pre-on-event this e) #t] + [just-pre? #f] + [else (when enabled? (on-event e)) #t])) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (key-event-as-string s) + (dispatch-on-char (new key-event% + [key-code (string-ref s 0)] + [shift-down #f] + [control-down #f] + [meta-down #f] + [alt-down #f] + [x 0] + [y 0] + [time-stamp (current-milliseconds)] ; FIXME + [caps-down #f]) + #f)) + + (define/public (on-char s) (void)) + (define/public (on-event m) (void)) + (define/public (on-size x y) (void)) + + (def/public-unimplemented on-drop-file) + (def/public-unimplemented get-handle) + (def/public-unimplemented set-phantom-size) + (def/public-unimplemented popup-menu) + (define/public (center a b) (void)) + (def/public-unimplemented get-text-extent) + (def/public-unimplemented refresh) + + (def/public-unimplemented screen-to-client) + + (define/public (client-to-screen xb yb) + (let* ([p (tell #:type _NSPoint (get-cocoa-window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint (get-cocoa-content) + convertPointToBase: #:type _NSPoint + (make-NSPoint (unbox xb) (flip-client (unbox yb)))))]) + (let ([new-y (send (get-wx-window) flip-screen (NSPoint-y p))]) + (set-box! xb (NSPoint-x p)) + (set-box! yb new-y)))) + + (def/public-unimplemented fit) + + (define/public (set-cursor c) (void)) + + (define/public (gets-focus?) #f) + + (def/public-unimplemented centre))) + +(define (queue-window-event win thunk) + (queue-event (send win get-eventspace) thunk)) diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt new file mode 100644 index 00000000..09d81c8a --- /dev/null +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt" + "../platform.rkt" + "local.rkt" + "queue.rkt") + +(provide clipboard<%> + clipboard-client% + get-the-clipboard + get-the-x-selection) + +(defclass clipboard-client% object% + (define types null) + (define es (current-eventspace)) + (define/public (get-client-eventspace) es) + (def/public (same-eventspace? [eventspace? e]) + (eq? e es)) + (def/public (get-types) + types) + (def/public (add-type [string? str]) + (set! types (cons (string->immutable-string str) types))) + (def/public (get-data [string? format]) + #f) + (def/public (on-replaced) + (void)) + (super-new)) + +(defclass clipboard% object% + (init x-selection?) + + (define driver (new clipboard-driver% + [x-selection? x-selection?])) + + (def/public (same-clipboard-client? [clipboard-client% c]) + (eq? c (send driver get-client))) + + (def/public (get-clipboard-bitmap [exact-integer? timestamp]) + #f) + (def/public-unimplemented set-clipboard-bitmap) + (def/public (get-clipboard-data [string? type] + [exact-integer? timestamp]) + (send driver get-data type)) + (def/public (get-clipboard-string [exact-integer? timestamp]) + (send driver get-text-data)) + (def/public-unimplemented set-clipboard-string) + + (def/public (set-clipboard-client [clipboard-client% c] + [exact-integer? timestamp]) + (send driver set-client c (send c get-types))) + + (super-new)) + +(define clipboard<%> (class->interface clipboard%)) + +(define the-clipboard (new clipboard% [x-selection? #f])) +(define the-x-selection + (if has-x-selection? + (new clipboard% [x-selection? #t]) + the-clipboard)) + +(define (get-the-clipboard) + the-clipboard) +(define (get-the-x-selection) + the-x-selection) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt new file mode 100644 index 00000000..a56df307 --- /dev/null +++ b/collects/mred/private/wx/common/cursor.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require racket/class + racket/draw + (only-in "../platform.rkt" cursor-driver%) + "../../syntax.rkt") + +(provide cursor%) + +(define standards (make-hash)) + +(defclass cursor% object% + + (init-rest args) + (define driver + (case-args + args + [([(symbol-in arrow bullseye cross hand ibeam watch blank + size-n/s size-e/w size-ne/sw size-nw/se) + sym]) + (or (hash-ref standards sym #f) + (let ([c (new cursor-driver%)]) + (send c set-standard sym) + (hash-set! standards sym c) + c))] + [([bitmap% image] + [bitmap% mask] + [(integer-in 0 15) [hot-spot-x 0]] + [(integer-in 0 15) [hot-spot-y 0]]) + (let ([c (new cursor-driver%)]) + (send c set-image image mask hot-spot-x hot-spot-y) + c)] + (init-name 'cursor%))) + + (def/public (ok?) (send driver ok?)) + (super-new)) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt new file mode 100644 index 00000000..dd5c0f61 --- /dev/null +++ b/collects/mred/private/wx/common/event.rkt @@ -0,0 +1,111 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide event% + mouse-event% + key-event% + control-event% + scroll-event% + popup-event%) + +(defclass event% object% + (init-properties [[exact-integer? time-stamp] 0]) + (super-new)) + +(defclass mouse-event% event% + ;; FIXME: check event-type + (init event-type) + (define et event-type) + (init-properties [[bool? left-down] #f] + [[bool? middle-down] #f] + [[bool? right-down] #f] + [[exact-integer? x] 0] + [[exact-integer? y] 0] + [[bool? shift-down] #f] + [[bool? control-down] #f] + [[bool? meta-down] #f] + [[bool? alt-down] #f]) + (init [time-stamp 0]) + (init-properties [[bool? caps-down] #f]) + (super-new [time-stamp time-stamp]) + + (def/public (get-event-type) et) + + (def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) + (and (memq et (case button + [(any) '(left-down left-up middle-down middle-up right-down right-up)] + [(left) '(left-down left-up)] + [(middle) '(middle-down middle-up)] + [(right) '(right-down right-up)])) + #t)) + + (def/public (button-down? [(symbol-in left middle right any) [button 'any]]) + (and (memq et (case button + [(any) '(left-down middle-down right-down)] + [(left) '(left-down)] + [(middle) '(middle-down)] + [(right) '(right-down)])) + #t)) + + (def/public (button-up? [(symbol-in left middle right any) [button 'any]]) + (and (memq et (case button + [(any) '(left-up middle-up right-up)] + [(left) '(left-up)] + [(middle) '(middle-up)] + [(right) '(right-up)])) + #t)) + + (def/public (dragging?) + (and (eq? et 'motion) + (or left-down middle-down right-down))) + + (def/public (entering?) + (eq? et 'enter)) + + (def/public (leaving?) + (eq? et 'leaving)) + + (def/public (moving?) + (and (eq? et 'motion) + (not (or left-down middle-down right-down))))) + +(defclass key-event% event% + (init-properties [[(make-alts symbol? char?) key-code] #\nul] + [[bool? shift-down] #f] + [[bool? control-down] #f] + [[bool? meta-down] #f] + [[bool? alt-down] #f] + [[exact-integer? x] 0] + [[exact-integer? y] 0]) + (init [time-stamp 0]) + (init-properties [[bool? caps-down] #f]) + (properties [[(make-alts symbol? char?) key-release-code] 'down] + [[(make-or-false (make-alts symbol? char?)) other-shift-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-altgr-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-shift-altgr-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-caps-key-code] #f]) + (super-new [time-stamp time-stamp])) + +(defclass control-event% event% + (init-properties [[(symbol-in button check-box choice + list-box list-box-dclick text-field + text-field-enter slider radio-box + menu-popdown menu-popdown-none tab-panel) + event-type] + ;; FIXME: should have no default + 'button]) + (init [time-stamp 0]) + (super-new [time-stamp time-stamp])) + +(defclass popup-event% control-event% + (properties [[any? menu-id] 0])) + +(defclass scroll-event% event% + (init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type] + 'thumb] + [[(symbol-in horizontal vertical) direction] 'vertical] + [[(integer-in 0 10000) position] 0]) + (init [time-stamp 0]) + (super-new [time-stamp time-stamp])) + diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt new file mode 100644 index 00000000..3d8543ee --- /dev/null +++ b/collects/mred/private/wx/common/handlers.rkt @@ -0,0 +1,28 @@ +#lang scheme/base + +(provide application-file-handler + application-quit-handler + application-about-handler + application-pref-handler) + +(define afh void) +(define application-file-handler + (case-lambda + [(proc) (set! afh proc)] + [() afh])) +(define aqh void) +(define application-quit-handler + (case-lambda + [(proc) (set! aqh proc)] + [() aqh])) +(define aah void) +(define application-about-handler + (case-lambda + [(proc) (set! aah proc)] + [() aah])) +(define aph void) +(define application-pref-handler + (case-lambda + [(proc) (set! aph proc)] + [() aph])) + diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt new file mode 100644 index 00000000..00b39c08 --- /dev/null +++ b/collects/mred/private/wx/common/local.rkt @@ -0,0 +1,8 @@ +#lang scheme/base +(require scheme/class) + +(provide (all-defined-out)) + +(define-local-member-name + ;; clipboard-client%: + get-client-eventspace) diff --git a/collects/mred/private/wx/common/procs.rkt b/collects/mred/private/wx/common/procs.rkt new file mode 100644 index 00000000..f28ba4a8 --- /dev/null +++ b/collects/mred/private/wx/common/procs.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require "../../syntax.rkt") + +(provide + label->plain-label) + +(define/top (label->plain-label [string? s]) + (regexp-replace* #rx"&." + (regexp-replace + #rx"[(]&.[)] *" + (regexp-replace #rx"\t.*$" s "") + "") + "")) + diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt new file mode 100644 index 00000000..80c4414f --- /dev/null +++ b/collects/mred/private/wx/common/queue.rkt @@ -0,0 +1,320 @@ +#lang racket/base +(require ffi/unsafe + racket/draw/utils + ffi/unsafe/atomic + "rbtree.rkt" + "../../lock.rkt") + +(provide queue-evt + set-check-queue! + set-queue-wakeup! + + add-event-boundary-callback! + add-event-boundary-sometimes-callback! + remove-event-boundary-callback! + pre-event-sync + + eventspace? + current-eventspace + queue-event + yield + (rename-out [make-new-eventspace make-eventspace]) + + event-dispatch-handler + eventspace-shutdown? + main-eventspace? + eventspace-handler-thread + + queue-callback + middle-queue-key + + make-timer-callback + add-timer-callback + remove-timer-callback + + register-frame-shown + + queue-quit-event) + +;; ------------------------------------------------------------ +;; Create a Scheme evt that is ready when a queue is nonempty + +(define _Scheme_Type _short) +(define-mz scheme_make_type (_fun _string -> _Scheme_Type)) +(define event-queue-type (scheme_make_type "event-queue")) + +(define-mz scheme_add_evt (_fun _Scheme_Type + (_fun #:atomic? #t _scheme -> _int) + (_fun #:atomic? #t _scheme _pointer -> _void) + _pointer + _int + -> _void)) + +(define (do-check-queue) #f) +(define (do-queue-wakeup fds) #f) + +(define (check-queue o) + (if (do-check-queue) 1 0)) +(define (queue-wakeup o fds) + (do-queue-wakeup fds)) +(scheme_add_evt event-queue-type check-queue queue-wakeup #f 0) +(define queue-evt (let ([p (malloc 16)] + [p2 (malloc 'nonatomic _pointer)]) + (memset p 0 16) + (ptr-set! p _Scheme_Type event-queue-type) + (ptr-set! p2 _pointer p) + (ptr-ref p2 _scheme))) + +(define (set-check-queue! check) + (set! do-check-queue check)) +(define (set-queue-wakeup! wake) + (set! do-queue-wakeup wake)) + +;; ------------------------------------------------------------ +;; Pre-event sync + +(define boundary-ht (make-hasheq)) +(define sometimes-boundary-ht (make-hasheq)) + +(define (add-event-boundary-callback! v proc) + (hash-set! boundary-ht v proc)) +(define (add-event-boundary-sometimes-callback! v proc) + (hash-set! sometimes-boundary-ht v proc)) + +(define (remove-event-boundary-callback! v) + (hash-remove! boundary-ht v) + (hash-remove! sometimes-boundary-ht v)) + +(define last-time -inf.0) + +;; Call this function only in atomic mode: +(define (pre-event-sync force?) + (let ([now (current-inexact-milliseconds)]) + (when (or (now . > . (+ last-time 200)) + force?) + (set! last-time now) + (hash-for-each sometimes-boundary-ht + (lambda (v p) (hash-remove! sometimes-boundary-ht v) (p v))))) + (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v)))) + +;; ------------------------------------------------------------ +;; Eventspaces + +(define-struct eventspace (handler-thread queue-proc done-evt) + #:property prop:evt (lambda (v) + (wrap-evt (eventspace-done-evt v) + (lambda (_) v)))) +(define-struct timed (alarm-evt msecs val [id #:mutable])) + +(define (make-timer-callback msecs thunk) + (make-timed (alarm-evt msecs) + msecs + thunk + 0)) + +(define (timed-compare a b) + (if (eq? a b) + 0 + (let ([am (timed-msecs a)] + [bm (timed-msecs b)]) + (cond + [(= am bm) (if ((timed-id a) . < . (timed-id b)) + -1 + 1)] + [(< am bm) -1] + [else 1])))) + +(define (make-eventspace* th) + (let ([done-sema (make-semaphore 1)]) + (make-eventspace th + (let ([count 0]) + (let ([lo (mcons #f #f)] + [med (mcons #f #f)] + [hi (mcons #f #f)] + [timer (box '())] + [timer-counter 0] + [frames (make-hasheq)] + [newly-posted-sema (make-semaphore)]) + (let* ([check-done + (lambda () + (if (or (positive? count) + (positive? (hash-count frames)) + (not (null? (unbox timer)))) + (semaphore-try-wait? done-sema) + (semaphore-post done-sema)))] + [enqueue (lambda (v q) + (set! count (add1 count)) + (check-done) + (let ([p (mcons v #f)]) + (if (mcdr q) + (set-mcdr! (mcdr q) p) + (set-mcar! q p)) + (set-mcdr! q p)))] + [first (lambda (q) + (and (mcar q) + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (set! count (sub1 count)) + (check-done) + (let ([result (mcar (mcar q))]) + (set-mcar! q (mcdr (mcar q))) + (unless (mcar q) + (set-mcdr! q #f)) + (end-atomic) + result)))))] + [remove-timer + (lambda (v timer) + (set-box! timer (rbtree-remove + timed-compare + v + (unbox timer))) + (check-done))]) + (case-lambda + [(v) + ;; Enqueue + (start-atomic) + (let ([val (cdr v)]) + (case (car v) + [(lo) (enqueue val lo)] + [(med) (enqueue val med)] + [(hi) (enqueue val hi)] + [(timer-add) + (set! timer-counter (add1 timer-counter)) + (set-timed-id! val timer-counter) + (set-box! timer + (rbtree-insert + timed-compare + val + (unbox timer))) + (check-done)] + [(timer-remove) (remove-timer val timer)] + [(frame-add) (hash-set! frames val #t) (check-done)] + [(frame-remove) (hash-remove! frames val) (check-done)])) + (semaphore-post newly-posted-sema) + (set! newly-posted-sema (make-semaphore)) + (check-done) + (end-atomic)] + [() + ;; Dequeue as evt + (start-atomic) + (let ([timer-first-ready + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (let* ([v (rbtree-min (unbox timer))] + [evt (timed-alarm-evt v)]) + (and (sync/timeout 0 evt) + ;; It's ready + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (remove-timer v timer) + (end-atomic) + (timed-val v))))))))] + [timer-first-wait + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (wrap-evt + (timed-alarm-evt (rbtree-min (unbox timer))) + (lambda (_) #f)))))]) + (let ([e (choice-evt + (wrap-evt (semaphore-peek-evt newly-posted-sema) + (lambda (_) #f)) + (or (first hi) + (timer-first-ready timer) + (first med) + (first lo) + (timer-first-wait timer) + ;; nothing else ready... + never-evt))]) + (end-atomic) + e))])))) + (semaphore-peek-evt done-sema)))) + +(define main-eventspace (make-eventspace* (current-thread))) +(define current-eventspace (make-parameter main-eventspace)) + +(define make-new-eventspace + (let ([make-eventspace + (lambda () + (letrec ([pause (make-semaphore)] + [es + (make-eventspace* + (thread + (lambda () + (sync pause) + (parameterize ([current-eventspace es]) + (yield (make-semaphore))))))]) + (semaphore-post pause) + es))]) + make-eventspace)) + +(define (queue-event eventspace thunk [level 'med]) + ((eventspace-queue-proc eventspace) (cons level thunk))) + +(define (handle-event thunk) + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt thunk)))) + +(define yield + (case-lambda + [() + (let ([e (current-eventspace)]) + (if (eq? (current-thread) (eventspace-handler-thread e)) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e)))]) + (if v + (begin (handle-event v) #t) + #f)) + #f))] + [(evt) + (unless (or (evt? evt) + (eq? evt 'wait)) + (raise-type-error 'yield "evt or 'wait" evt)) + (let* ([e (current-eventspace)] + [handler? (eq? (current-thread) (eventspace-handler-thread e))]) + (cond + [(and (eq? evt 'wait) + (not handler?)) + #t] + [handler? + (sync (if (eq? evt 'wait) + (wrap-evt e (lambda (_) #t)) + evt) + (handle-evt ((eventspace-queue-proc e)) + (lambda (v) + (when v (handle-event v)) + (yield evt))))] + [else + (sync e)]))])) + +(define event-dispatch-handler (make-parameter void)) +(define (eventspace-shutdown? e) #f) +(define (main-eventspace? e) + (eq? e main-eventspace)) + +(define (queue-callback thunk [high? #f]) + (queue-event (current-eventspace) thunk (cond + [(not high?) 'lo] + [(eq? high? middle-queue-key) 'med] + [else 'hi]))) + +(define middle-queue-key (gensym 'middle)) + + +(define (add-timer-callback cb) + (queue-event (current-eventspace) cb 'timer-add)) +(define (remove-timer-callback cb) + (queue-event (current-eventspace) cb 'timer-remove)) + +(define (register-frame-shown f on?) + (queue-event (current-eventspace) f (if on? + 'frame-add + 'frame-remove))) + +(define (queue-quit-event) + (printf "quit!\n")) diff --git a/collects/mred/private/wx/common/rbtree.rkt b/collects/mred/private/wx/common/rbtree.rkt new file mode 100644 index 00000000..a01817e1 --- /dev/null +++ b/collects/mred/private/wx/common/rbtree.rkt @@ -0,0 +1,316 @@ +#lang scheme/base + +;;; red-black-tree.rkt -- Jens Axel S�gaard and Carl Eastlund -- 3rd nov 2003 + +;;; PURPOSE + +; This is an implementation of red/black trees, based on the galore.plt code + +;;; HISTORY + +; This is direct port of Jean-Christophe Filliatre's implementation +; of red-black trees in Ocaml. + +;; 13th jan 2010 [mflatt] +; - simplified for incorporation into MrEd; +; something like this should be in `scheme', instead. +;; 22nd jan 2004 [soegaard] +; - added set? +; - fixed bug in inter-list reported by Pinku Surana +;; 15th feb 2005 [soegaard] +; - numerous modifications to handle the case were +; elm= is finer than elm> and elm< +; - fixed serious bug in unbalanced-left +; (one sub tree was discarded, the other cloned) +; 17th feb 2005 [soegaard] +; - fixed bug in diff-list introduced (hopefully) the 15th +; 2nd nov 2005 [soegaard] +; - changed from unit to module/compare approach +; - renamed from red-black-tree-set.scm to raw-red-black-tree-set.scm +; 5th apr 2006 [cce] +; - copied from module to class approach +; - renamed to red-black-tree (from raw-red-black-tree-set) +; - inlined the provide declaration +; - fixed errors in the commented contracts for empty and get +; 2nd may 2006 [sstrickl] +; - fixed error in insert/combiner (replacing a black node turned it red) +; 5th may 2006 [cce] +; - udpated license statement regarding permission to use LGPL v2.1 + +;;; LICENSE + +; Rbset: Sets implemented as red-black trees. +; Copyright (C) 2000 Jean-Christophe FILLIATRE +; +; This software is free software; you can redistribute it and/or +; modify it under the terms of the GNU Library General Public +; License version 2, as published by the Free Software Foundation. +; +; 5th May 2006: Jean-Christophe Filliatre has given express written +; permission to redistribute and/or modify this software under the terms +; of any newer version of the GNU LGPL. +; +; This software is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +; +; See the GNU Library General Public License version 2 for more details +; (enclosed in the file LGPL). +; + +;; SETS IMPLEMENTED AS REB-BLACK TREES. + +(require scheme/match + (for-syntax scheme/base)) +(define-match-expander $ + (lambda (stx) + (syntax-case stx () + [(_ id pat ...) #'(struct id (pat ...))]))) + +(define-syntax-rule (if3 v less same more) + (let ([x v]) + (cond + [(x . < . 0) less] + [(x . = . 0) same] + [else more]))) + +(provide rbtree-get ; compare element set -> element/f + rbtree-insert ; compare element set -> set + rbtree-remove ; compare element set -> set + rbtree-min ; set -> element + ) + + +;; DATA DEFINITION + +;; A RED/BLACK TREE is either +;; 1. empty +;; or 2. (make-B l x r) +;; or 3. (make-R l x r) +;; where l and r are red/black trees and x is an element. + +(define empty '()) ; considered black +(define empty? null?) + +(define-struct B (l x r) #:transparent) ; Black tree +(define-struct R (l x r) #:transparent) ; Red tree +;; Constructor shorthands +(define (B- l x r) (make-B l x r)) +(define (R- l x r) (make-R l x r)) + +;; type predicate +(define (red-black-tree? s) + (or (null? s) (B? s) (R? s))) + + +;; for debugging +(define (->sexp t) + (define -> ->sexp) + (match t + ['() '()] + [($ B l x r) `(B ,(-> l) ,x ,(-> r))] + [($ R l x r) `(R ,(-> l) ,x ,(-> r))])) + + +;; INVARIANTS + +;; (* Invariants: (1) a red node has no red son, and (2) any path from the +;; root to a leaf has the same number of black nodes *) +;; +;; (* Note the use of two constructors [Black] and [Red] to save space +;; (resulting in longer code at a few places, e.g. in function [remove]). +;; These red-black trees saves 20\% of space w.r.t Ocaml's AVL, which +;; store the height into a fourth argument. *) + +;; type elt = Ord.t +;; type t = Empty | Black of t * elt * t | Red of t * elt * t + +;; (*s For debug only: checks whether a tree is properly colored *) + +;; check : rbt -> integer +;; checks invariants and return black height, +;; if the invariants are fulfilled +#; +(define (check s) + (match s + ['() 0] + [($ R ($ R _ _ _) _ _) (error "Red node with red parent" s)] + [($ R _ _ ($ R _ _ _)) (error "Red node with red parent" s)] + [($ B l _ r) (let ([height-left (check l)] + [height-right (check r)]) + (if (not (= height-left height-right)) + (error) + (+ height-left 1)))] + [($ R l _ r) (let ([height-left (check l)] + [height-right (check r)]) + (if (not (= height-left height-right)) + (error) + height-left))])) + +;; SET OPERATIONS + +(define (rbtree-get cmp x s) + (match s + ['() #f] + [($ B l v r) (if3 (cmp x v) + (rbtree-get cmp x l) + v + (rbtree-get cmp x r))] + [($ R l v r) (if3 (cmp x v) + (rbtree-get cmp x l) + v + (rbtree-get cmp x r))])) + +(define (rbtree-min s) + (match s + [($ B '() v _) v] + [($ R '() v _) v] + [($ B l _ _) (rbtree-min l)] + [($ R l _ _) (rbtree-min l)] + ['() (error 'rbtree-min "an empty set does not have an mimimum element")])) + +;; BALANCING + +(define (lbalance x1 x2 x3) + (let ([z x2] [d x3]) + (match x1 + [($ R ($ R a x b) y c) (R- (B- a x b) y (B- c z d))] + [($ R a x ($ R b y c)) (R- (B- a x b) y (B- c z d))] + [_ (B- x1 x2 x3)]))) + +(define (rbalance x1 x2 x3) + (let ([a x1] [x x2]) + (match x3 + [($ R ($ R b y c) z d) (R- (B- a x b) y (B- c z d))] + [($ R b y ($ R c z d)) (R- (B- a x b) y (B- c z d))] + [_ (B- x1 x2 x3)]))) + +;; INSERTION + +(define (rbtree-insert cmp x s) + (define (ins s) + (match s + ['() (R- empty x empty)] + [($ R a y b) (if3 (cmp x y) + (R- (ins a) y b) + s + (R- a y (ins b)))] + [($ B a y b) (if3 (cmp x y) + (lbalance (ins a) y b) + s + (rbalance a y (ins b)))])) + (let ([s1 (ins s)]) + ; color the root black + (match s1 + [($ B _ _ _) s1] + [($ R a y b) (B- a y b)] + ['() (error)]))) + +;; REMOVAL + +;; (* [unbalanced_left] repares invariant (2) when the black height of the +;; left son exceeds (by 1) the black height of the right son *) +;; [original spelling kept -- a quote is a quote ] + +(define (unbalanced-left s) + (match s + [($ R ($ B t1 x1 t2) x2 t3) (values (lbalance (R- t1 x1 t2) x2 t3) #f)] + [($ B ($ B t1 x1 t2) x2 t3) (values (lbalance (R- t1 x1 t2) x2 t3) #t)] + [($ B ($ R t1 x1 ($ B t2 x2 t3)) x3 t4) (values (B- t1 x1 (lbalance (R- t2 x2 t3) x3 t4)) #f)] + [_ (error 'unbalanced-left + (format "Black height of both sons were the same: ~a" + (->sexp s)))])) + +;; (* [unbalanced_right] repares invariant (2) when the black height of the +;; right son exceeds (by 1) the black height of the left son *) + +(define (unbalanced-right s) + (match s + [($ R t1 x1 ($ B t2 x2 t3)) (values (rbalance t1 x1 (R- t2 x2 t3)) #f)] + [($ B t1 x1 ($ B t2 x2 t3)) (values (rbalance t1 x1 (R- t2 x2 t3)) #t)] + [($ B t1 x1 ($ R ($ B t2 x2 t3) x3 t4)) (values (B- (rbalance t1 x1 (R- t2 x2 t3)) x3 t4) #f)] + [_ (error 'unbalanced-right + (format "Black height of both sons were the same: ~a" + (->sexp s)))])) + + + +;; (* [remove_min s = (s',m,b)] extracts the minimum [m] of [s], [s'] being the +;; resulting set, and indicates with [b] whether the black height has +;; decreased *) + +(define (remove-min s) + (match s + ['() (error "remove-min: Called on empty set")] + ;; minimum is reached + [($ B '() x '()) (values empty x #t)] + [($ B '() x ($ R l y r)) (values (B- l y r) x #f)] + [($ B '() _ ($ B _ _ _)) (error)] + [($ R '() x r) (values r x #f)] + ;; minimum is recursively extracted from [l] + [($ B l x r) (let-values ([(l1 m d) (remove-min l)]) + (let ([t (B- l1 x r)]) + (if d + (let-values ([(t d1) (unbalanced-right t)]) + (values t m d1)) + (values t m #f))))] + [($ R l x r) (let-values ([(l1 m d) (remove-min l)]) + (let ([t (R- l1 x r)]) + (if d + (let-values ([(t d1) (unbalanced-right t)]) + (values t m d1)) + (values t m #f))))])) + + +(define (blackify s) + (match s + [($ R l x r) (values (B- l x r) #f)] + [_ (values s #t)])) + +;; (* [remove_aux x s = (s',b)] removes [x] from [s] and indicates with [b] +;; whether the black height has decreased *) + +(define (rbtree-remove cmp x s) + (define (remove-aux s) + (match s + ['() (values empty #f)] + [($ B l y r) (if3 (cmp x y) + (let-values ([(l1 d) (remove-aux l)]) + (let ([t (B- l1 y r)]) + (if d + (unbalanced-right t) + (values t #f)))) + + (match r + ['() (blackify l)] + [_ (let-values ([(r1 m d) (remove-min r)]) + (let ([t (B- l m r1)]) + (if d + (unbalanced-left t) + (values t #f))))]) + + (let-values ([(r1 d) (remove-aux r)]) + (let ([t (B- l y r1)]) + (if d + (unbalanced-left t) + (values t #f)))))] + [($ R l y r) (if3 (cmp x y) + (let-values ([(l1 d) (remove-aux l)]) + (let ([t (R- l1 y r)]) + (if d + (unbalanced-right t) + (values t #f)))) + (match r + ['() (values l #f)] + [_ (let-values ([(r1 m d) (remove-min r)]) + (let ([t (R- l m r1)]) + (if d + (unbalanced-left t) + (values t #f))))]) + (let-values ([(r1 d) (remove-aux r)]) + (let ([t (R- l y r1)]) + (if d + (unbalanced-left t) + (values t #f)))))])) + (let-values ([(s1 ignore) (remove-aux s)]) + s1)) diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt new file mode 100644 index 00000000..79e27f63 --- /dev/null +++ b/collects/mred/private/wx/common/timer.rkt @@ -0,0 +1,47 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "../../lock.rkt" + "queue.rkt") + +(provide timer%) + +;; FIXME: need checks +(defclass timer% object% + (init [notify-callback void] + [(ival interval) #f] + [just-once? #f]) + (define notify-cb notify-callback) + (define current-interval ival) + (define current-once? (and just-once? #t)) + (define cb #f) + (def/public (interval) current-interval) + (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) + (as-entry + (lambda () + (stop) + (set! current-interval msec) + (set! current-once? (and once? #t)) + (letrec ([new-cb + (make-timer-callback (+ msec (current-inexact-milliseconds)) + (lambda () + (when (eq? cb new-cb) + (notify) + (as-entry + (lambda () + (unless once? + (when (eq? cb new-cb) + (start msec #f))))))))]) + (set! cb new-cb) + (add-timer-callback new-cb))))) + (def/public (stop) + (as-entry + (lambda () + (when cb + (remove-timer-callback cb) + (set! cb #f))))) + (def/public (notify) (notify-cb) (void)) + (super-new) + (when ival + (start ival just-once?))) + diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt new file mode 100644 index 00000000..8de704c5 --- /dev/null +++ b/collects/mred/private/wx/common/utils.rkt @@ -0,0 +1,8 @@ +#lang scheme/base +(require scheme/foreign) +(unsafe!) + +(provide define-mz) + +(define-syntax-rule (define-mz id type) + (define id (get-ffi-obj 'id #f type))) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt new file mode 100644 index 00000000..65c4b0d5 --- /dev/null +++ b/collects/mred/private/wx/gtk/button.rkt @@ -0,0 +1,78 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "pixbuf.rkt" + "../common/event.rkt") +(unsafe!) + +(provide button% + button-core%) + +;; ---------------------------------------- + +(define-gtk gtk_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_button_new (_fun -> _GtkWidget)) +(define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) + +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx queue-clicked)))) + +(defclass button-core% item% + (init parent cb label x y w h style font + [gtk_new_with_label gtk_button_new_with_label] + [gtk_new gtk_button_new]) + (init-field [event-type 'button]) + (inherit get-gtk set-auto-size is-window-enabled? + get-window-gtk) + + (super-new [parent parent] + [gtk (cond + [(or (string? label) (not label)) + (gtk_new_with_label (or label ""))] + [(send label ok?) + (let ([gtk (gtk_new)] + [image-gtk (gtk_image_new_from_pixbuf + (bitmap->pixbuf label))]) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk) + gtk)] + [else + (gtk_new_with_label "")])] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (when (eq? event-type 'button) + (set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk) + GTK_CAN_DEFAULT))) + + (set-auto-size) + + (connect-clicked gtk) + + (when (memq 'border style) (set-border #t)) + + (define callback cb) + (define/public (clicked) + (when (is-window-enabled?) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)])))) + (define/public (queue-clicked) + ;; Called from event-handling thread + (queue-window-event this (lambda () (clicked)))) + + (define/public (set-border on?) + (gtk_window_set_default (get-window-gtk) (if on? gtk #f)))) + +(defclass button% button-core% + (super-new)) + diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt new file mode 100644 index 00000000..6ad214ca --- /dev/null +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw + ffi/unsafe/alloc + racket/draw/color + "../../syntax.rkt" + "../common/event.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "client-window.rkt" + "widget.rkt" + "dc.rkt") + +(provide canvas%) + +;; ---------------------------------------- + +(define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) + +(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) + +(define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject +(define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment)) +(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void)) +(define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*)) +(define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*)) +(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*)) +(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)) +(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)) + +(define-cstruct _GdkColor ([pixel _uint32] + [red _uint16] + [green _uint16] + [blue _uint16])) + +(define-gdk gdk_gc_unref (_fun _pointer -> _void) + #:wrap (deallocator)) +(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) + #:wrap (allocator gdk_gc_unref)) +(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) +(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) + +(define (handle-expose gtk event) + (let ([wx (gtk->wx gtk)]) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (g_object_get_window gtk) gc #t + 0 0 32000 32000))) + (queue-window-event wx (lambda () + (send wx on-paint)))) + #t) +(define handle_expose + (function-ptr handle-expose (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _gboolean))) + +(define (handle-value-changed-h gtk ignored) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () (send wx do-scroll 'horizontal)))) + #t) +(define handle_value_changed_h + (function-ptr handle-value-changed-h (_fun #:atomic? #t _GtkWidget _pointer -> _void))) + +(define (handle-value-changed-v gtk ignored) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () (send wx do-scroll 'vertical)))) + #t) +(define handle_value_changed_v + (function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void))) + + +(define canvas% + (class (client-size-mixin window%) + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-gtk set-size get-client-size) + + (define client-gtk (gtk_drawing_area_new)) + (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) + (if (or (memq 'hscroll style) + (memq 'vscroll style)) + (let ([hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (gtk_hbox_new #f 0)] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (gtk_widget_show hscroll) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (gtk_widget_show v2) + (gtk_widget_show h2) + (gtk_widget_show resize-box) + (gtk_widget_show client-gtk) + (values h hadj vadj h2 v2 resize-box))) + (values client-gtk #f #f #f #f #f))) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [no-show? (memq 'deleted style)] + [extra-gtks (if (eq? client-gtk gtk) + null + (list client-gtk hscroll-adj vscroll-adj))]) + + (set-size x y w h) + + (define dc (new dc% + [gtk client-gtk] + [get-client-size (lambda () + (let ([w (box 0)] + [h (box 0)]) + (get-client-size w h) + (values (unbox w) (unbox h))))])) + + (gtk_widget_realize gtk) + (gtk_widget_realize client-gtk) + + (when resize-box + (let ([r (make-GtkRequisition 0 0)]) + (gtk_widget_size_request hscroll-gtk r) + (gtk_widget_set_size_request resize-box + (GtkRequisition-height r) + (GtkRequisition-height r)))) + + (g_signal_connect client-gtk "expose_event" handle_expose) + (connect-key-and-mouse client-gtk) + (connect-focus client-gtk) + (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK)) + (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) + GTK_CAN_FOCUS)) + + (when hscroll-adj + (g_signal_connect hscroll-adj "value-changed" handle_value_changed_h)) + (when vscroll-adj + (g_signal_connect vscroll-adj "value-changed" handle_value_changed_v)) + + (define/override (direct-update?) #f) + + (define/public (get-dc) dc) + + (define/override (get-client-gtk) client-gtk) + (define/override (handles-events?) #t) + + (define/public (on-paint) (void)) + + (define/override (internal-on-client-size w h) + (send dc reset-dc-size)) + + (define/public (show-scrollbars h? v?) + (when hscroll-gtk + (if h? + (gtk_widget_show hscroll-gtk) + (gtk_widget_hide hscroll-gtk))) + (when vscroll-gtk + (if v? + (gtk_widget_show vscroll-gtk) + (gtk_widget_hide vscroll-gtk)))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (when hscroll-adj + (gtk_adjustment_configure hscroll-adj h-pos 0 h-len 1 h-page h-page)) + (when vscroll-adj + (gtk_adjustment_configure vscroll-adj v-pos 0 v-len 1 v-page v-page))) + + (define/private (dispatch which proc) + (if (eq? which 'vertical) + (when vscroll-adj (proc vscroll-adj)) + (when hscroll-adj (proc hscroll-adj)))) + + (define/public (set-scroll-page which v) + (dispatch which (lambda (adj) + (let ([old (gtk_adjustment_get_page_size adj)]) + (unless (= old v) + (gtk_adjustment_set_page_size adj v) + (gtk_adjustment_set_page_increment adj v) + (gtk_adjustment_set_upper adj (+ (- v old) + (gtk_adjustment_get_upper adj)))))))) + (define/public (set-scroll-range which v) + (dispatch which (lambda (adj) + (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) + (define/public (set-scroll-pos which v) + (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) + + (define/public (get-scroll-page which) + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_page_size adj) + (gtk_adjustment_get_page_size adj)))))) + (define/public (get-scroll-range which) + (->long (dispatch which gtk_adjustment_get_upper))) + (define/public (get-scroll-pos which) + (->long (dispatch which gtk_adjustment_get_value))) + + (define clear-bg? + (and (not (memq 'transparent style)) + (not (memq 'no-autoclear style)))) + (define gc #f) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) bg-col) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + (if clear-bg? + (let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) + (unless gc + (let ([w (g_object_get_window gtk)]) + (set! gc (gdk_gc_new w)))) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 + (conv (color-red bg-col)) + (conv (color-green bg-col)) + (conv (color-blue bg-col)))) + gc) + #f)) + + (def/public-unimplemented set-background-to-gray) + + (define/public (do-scroll direction) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)]))) + (define/public (on-scroll e) (void)) + + (def/public-unimplemented scroll) + (def/public-unimplemented warp-pointer) + (def/public-unimplemented view-start) + (define/public (set-resize-corner on?) (void)) + + (def/public-unimplemented get-virtual-size))) diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt new file mode 100644 index 00000000..495e61ee --- /dev/null +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -0,0 +1,38 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "button.rkt" + "utils.rkt" + "types.rkt" + "../../lock.rkt") +(unsafe!) + +(provide check-box%) + +;; ---------------------------------------- + +(define-gtk gtk_check_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_check_button_new (_fun -> _GtkWidget)) +(define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) + +(defclass check-box% button-core% + (super-new [gtk_new_with_label gtk_check_button_new_with_label] + [gtk_new gtk_check_button_new] + [event-type 'check-box]) + (inherit get-gtk) + + (define/public (set-value v) + (as-entry + (lambda () + (set! no-clicked? #t) + (gtk_toggle_button_set_active (get-gtk) v) + (set! no-clicked? #f)))) + + (define no-clicked? #f) + (define/override (queue-clicked) + (unless no-clicked? (super queue-clicked))) + + (define/public (get-value) + (gtk_toggle_button_get_active (get-gtk)))) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt new file mode 100644 index 00000000..8af7770d --- /dev/null +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -0,0 +1,103 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt") +(unsafe!) + +(provide choice%) + +;; ---------------------------------------- + +(define-gtk gtk_combo_box_new_text (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) + +(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) +(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx queue-clicked)))) + +(defclass choice% item% + (init parent cb label + x y w h + choices style font) + (inherit get-gtk set-auto-size) + + (define gtk (gtk_combo_box_new_text)) + (define count (length choices)) + + (for ([l (in-list choices)]) + (gtk_combo_box_append_text gtk l)) + + ;; Hack to access the combobox's private child, where is + ;; where the keyboard focus goes. + (define button-gtk + (let ([all null] + [ext null]) + (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) + (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) + (for-each (lambda (e) + (set! all (filter (lambda (a) (not (ptr-equal? a e))) + all))) + ext) + (unless (= 1 (length all)) + (error "expected Gtk combobox to have one private child")) + (car all))) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks (list button-gtk)] + [no-show? (memq 'deleted style)]) + + (gtk_combo_box_set_active gtk 0) + + (set-auto-size) + + (connect-changed gtk) + (connect-focus button-gtk) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))) + (define ignore-clicked? #f) + (define/public (queue-clicked) + ;; called in event-handling thread + (unless ignore-clicked? + (queue-window-event this (lambda () (clicked))))) + + (define/public (set-selection i) + (as-entry + (lambda () + (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) + (as-entry + (lambda () + (for ([i (in-range count)]) + (gtk_combo_box_remove_text gtk 0)) + (set! count 0)))) + (define/public (append l) + (as-entry + (lambda () + (set! count (add1 count)) + (gtk_combo_box_append_text gtk l) + (when (= count 1) + (set-selection 0)))))) diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt new file mode 100644 index 00000000..60cb0d38 --- /dev/null +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -0,0 +1,51 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "widget.rkt" + "window.rkt" + "utils.rkt" + "const.rkt" + "types.rkt") +(unsafe!) + +(provide client-size-mixin) + +;; ---------------------------------------- + +(define-signal-handler connect-size-allocate "size-allocate" + (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (send wx remember-client-size + (GtkAllocation-width a) + (GtkAllocation-height a))) + #t)) + +(define (client-size-mixin %) + (class % + (init client-gtk) + + (connect-size-allocate client-gtk) + + (define client-w 0) + (define client-h 0) + + (define/public (on-client-size w h) (void)) + + (define/public (remember-client-size w h) + ;; Called in the Gtk event-loop thread + (set! client-w w) + (set! client-h h) + (queue-window-event this (lambda () + (internal-on-client-size w h) + (on-client-size w h)))) + + (define/public (internal-on-client-size w h) + (void)) + + (define/override (get-client-size xb yb) + (set-box! xb client-w) + (set-box! yb client-h)) + + (super-new))) \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt new file mode 100644 index 00000000..c2f0e3e8 --- /dev/null +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -0,0 +1,142 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "../common/queue.rkt" + "../common/local.rkt" + "../common/bstr.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) + +(provide clipboard-driver% + has-x-selection?) + +(define (has-x-selection?) #t) + +(define _GdkAtom _int) +(define _GtkClipboard (_cpointer 'GtkClipboard)) +(define _GtkDisplay _pointer) +(define _GtkSelectionData (_cpointer 'GtkSelectionData)) + +(define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom)) + +(define-gtk gtk_clipboard_get (_fun _GdkAtom -> _GtkClipboard)) +(define-gtk gtk_clipboard_set_with_data (_fun _GtkClipboard _pointer _uint + _fpointer _fpointer + _pointer + -> _void)) +(define-gtk gtk_selection_data_set (_fun _GtkSelectionData + _GdkAtom + _int + _ubyte + _int + -> _void)) +(define-gtk gtk_clipboard_wait_for_contents (_fun _GtkClipboard _GdkAtom -> (_or-null _GtkSelectionData))) +(define-gtk gtk_selection_data_free (_fun _GtkSelectionData -> _void)) +(define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int)) +(define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer)) +(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _string)) + +(define-cstruct _GtkTargetEntry ([target _pointer] + [flags _uint] + [info _uint])) + +(define (get-data cb sel-data info self-box) + (send (ptr-ref self-box _scheme) provide-data info sel-data)) +(define get_data + (function-ptr get-data (_fun #:atomic? #t _GtkClipboard _GtkSelectionData _int _pointer -> _void))) + +(define (clear-owner cb self-box) + (send (ptr-ref self-box _scheme) replaced)) +(define clear_owner + (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) + + +(defclass clipboard-driver% object% + (init-field [x-selection? #f]) + + (define client #f) + (define client-data #f) + + (define cb (gtk_clipboard_get + (if x-selection? + (gdk_atom_intern "CLIPBOARD" #t) + (gdk_atom_intern "PRIMARY" #t)))) + (define self-box (malloc-immobile-cell this)) + + (define/public (get-client) client) + + (define/public (set-client c types) + (if x-selection? + ;; For now, we can't call it on demand, so we don't call at all: + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced))) + ;; In clipboard mode (as opposed to X selection), we can get the data + ;; now, so it's ready if anyone asks: + (let ([all-data (for/list ([t (in-list types)]) + (send c get-data t))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) + ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t i) + (set-GtkTargetEntry-info! t 0)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + self-box) + (free target-strings))))) + + (define/public (replaced) + ;; Called in Gtk event-dispatch thread --- atomically with respect + ;; to any other thread + (let ([c client]) + (when c + (set! client #f) + (set! client-data #f) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))))) + + (define/public (provide-data i sel-data) + ;; Called in Gtk event-dispatch thread --- atomically with respect + ;; to any other thread + (let ([bstr (if client + (list-ref client-data i) + #"")]) + (gtk_selection_data_set sel-data + (gdk_atom_intern "UTF8_STRING" #t) + 8 + bstr + (bytes-length bstr)))) + + (define/public (get-data format) + (let ([process (lambda (v) + (and v + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data v) + (gtk_selection_data_get_length v) + 1)]) + (gtk_selection_data_free v) + bstr)))]) + (process (gtk_clipboard_wait_for_contents cb (gdk_atom_intern format #t))))) + + (define/public (get-text-data) + (gtk_clipboard_wait_for_text cb)) + + (super-new)) + diff --git a/collects/mred/private/wx/gtk/const.rkt b/collects/mred/private/wx/gtk/const.rkt new file mode 100644 index 00000000..5a6b8d6d --- /dev/null +++ b/collects/mred/private/wx/gtk/const.rkt @@ -0,0 +1,122 @@ +#lang scheme/base + +(provide (except-out (all-defined-out) <<)) + +(define GTK_WINDOW_TOPLEVEL 0) + +(define << arithmetic-shift) + +(define GDK_EXPOSURE_MASK (1 . << . 1)) +(define GDK_POINTER_MOTION_MASK (1 . << . 2)) +(define GDK_POINTER_MOTION_HINT_MASK (1 . << . 3)) +(define GDK_BUTTON_MOTION_MASK (1 . << . 4)) +(define GDK_BUTTON1_MOTION_MASK (1 . << . 5)) +(define GDK_BUTTON2_MOTION_MASK (1 . << . 6)) +(define GDK_BUTTON3_MOTION_MASK (1 . << . 7)) +(define GDK_BUTTON_PRESS_MASK (1 . << . 8)) +(define GDK_BUTTON_RELEASE_MASK (1 . << . 9)) +(define GDK_KEY_PRESS_MASK (1 . << . 10)) +(define GDK_KEY_RELEASE_MASK (1 . << . 11)) +(define GDK_ENTER_NOTIFY_MASK (1 . << . 12)) +(define GDK_LEAVE_NOTIFY_MASK (1 . << . 13)) +(define GDK_FOCUS_CHANGE_MASK (1 . << . 14)) +(define GDK_STRUCTURE_MASK (1 . << . 15)) +(define GDK_PROPERTY_CHANGE_MASK (1 . << . 16)) +(define GDK_VISIBILITY_NOTIFY_MASK (1 . << . 17)) +(define GDK_PROXIMITY_IN_MASK (1 . << . 18)) +(define GDK_PROXIMITY_OUT_MASK (1 . << . 19)) +(define GDK_SUBSTRUCTURE_MASK (1 . << . 20)) +(define GDK_SCROLL_MASK (1 . << . 21)) +(define GDK_ALL_EVENTS_MASK #x3FFFFE) + + +(define GTK_TOPLEVEL (1 . << . 4)) +(define GTK_NO_WINDOW (1 . << . 5)) +(define GTK_REALIZED (1 . << . 6)) +(define GTK_MAPPED (1 . << . 7)) +(define GTK_VISIBLE (1 . << . 8)) +(define GTK_SENSITIVE (1 . << . 9)) +(define GTK_PARENT_SENSITIVE (1 . << . 10)) +(define GTK_CAN_FOCUS (1 . << . 11)) +(define GTK_HAS_FOCUS (1 . << . 12)) +(define GTK_CAN_DEFAULT (1 . << . 13)) +(define GTK_HAS_DEFAULT (1 . << . 14)) +(define GTK_HAS_GRAB (1 . << . 15)) +(define GTK_RC_STYLE (1 . << . 16)) +(define GTK_COMPOSITE_CHILD (1 . << . 17)) +(define GTK_NO_REPARENT (1 . << . 18)) +(define GTK_APP_PAINTABLE (1 . << . 19)) +(define GTK_RECEIVES_DEFAULT (1 . << . 20)) +(define GTK_DOUBLE_BUFFERED (1 . << . 21)) +(define GTK_NO_SHOW_ALL (1 . << . 22)) + +(define GDK_SHIFT_MASK (1 . << . 0)) +(define GDK_LOCK_MASK (1 . << . 1)) +(define GDK_CONTROL_MASK (1 . << . 2)) +(define GDK_MOD1_MASK (1 . << . 3)) +(define GDK_MOD2_MASK (1 . << . 4)) +(define GDK_MOD3_MASK (1 . << . 5)) +(define GDK_MOD4_MASK (1 . << . 6)) +(define GDK_MOD5_MASK (1 . << . 7)) +(define GDK_BUTTON1_MASK (1 . << . 8)) +(define GDK_BUTTON2_MASK (1 . << . 9)) +(define GDK_BUTTON3_MASK (1 . << . 10)) +(define GDK_BUTTON4_MASK (1 . << . 11)) +(define GDK_BUTTON5_MASK (1 . << . 12)) +(define GDK_SUPER_MASK (1 . << . 26)) +(define GDK_HYPER_MASK (1 . << . 27)) +(define GDK_META_MASK (1 . << . 28)) +(define GDK_RELEASE_MASK (1 . << . 30)) + +(define GDK_NOTHING -1) +(define GDK_DELETE 0) +(define GDK_DESTROY 1) +(define GDK_EXPOSE 2) +(define GDK_MOTION_NOTIFY 3) +(define GDK_BUTTON_PRESS 4) +(define GDK_2BUTTON_PRESS 5) +(define GDK_3BUTTON_PRESS 6) +(define GDK_BUTTON_RELEASE 7) +(define GDK_KEY_PRESS 8) +(define GDK_KEY_RELEASE 9) +(define GDK_ENTER_NOTIFY 10) +(define GDK_LEAVE_NOTIFY 11) +(define GDK_FOCUS_CHANGE 12) +(define GDK_CONFIGURE 13) +(define GDK_MAP 14) +(define GDK_UNMAP 15) +(define GDK_PROPERTY_NOTIFY 16) +(define GDK_SELECTION_CLEAR 17) +(define GDK_SELECTION_REQUEST 18) +(define GDK_SELECTION_NOTIFY 19) +(define GDK_PROXIMITY_IN 20) +(define GDK_PROXIMITY_OUT 21) +(define GDK_DRAG_ENTER 22) +(define GDK_DRAG_LEAVE 23) +(define GDK_DRAG_MOTION 24) +(define GDK_DRAG_STATUS 25) +(define GDK_DROP_START 26) +(define GDK_DROP_FINISHED 27) +(define GDK_CLIENT_EVENT 28) +(define GDK_VISIBILITY_NOTIFY 29) +(define GDK_NO_EXPOSE 30) +(define GDK_SCROLL 31) +(define GDK_WINDOW_STATE 32) +(define GDK_SETTING 33) +(define GDK_OWNER_CHANGE 34) +(define GDK_GRAB_BROKEN 35) +(define GDK_DAMAGE 36) + +(define G_TYPE_STRING (16 . << . 2)) + +(define GTK_POLICY_ALWAYS 0) +(define GTK_POLICY_AUTOMATIC 1) +(define GTK_POLICY_NEVER 2) + +(define GDK_WINDOW_STATE_WITHDRAWN (1 . << . 0)) +(define GDK_WINDOW_STATE_ICONIFIED (1 . << . 1)) +(define GDK_WINDOW_STATE_MAXIMIZED (1 . << . 2)) +(define GDK_WINDOW_STATE_STICKY (1 . << . 3)) +(define GDK_WINDOW_STATE_FULLSCREEN (1 . << . 4)) +(define GDK_WINDOW_STATE_ABOVE (1 . << . 5)) +(define GDK_WINDOW_STATE_BELOW (1 . << . 6)) diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt new file mode 100644 index 00000000..75a30429 --- /dev/null +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -0,0 +1,10 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide cursor-driver%) + +(defclass cursor-driver% object% + (def/public-unimplemented ok?) + (define/public (set-standard sym) (void)) + (super-new)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt new file mode 100644 index 00000000..018db564 --- /dev/null +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "../../lock.rkt" + racket/draw/cairo + racket/draw/dc + racket/draw/local + ffi/unsafe/alloc) + +(provide dc% reset-dc-size) + +(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) + #:wrap (allocator cairo_destroy)) + +(define-local-member-name + reset-dc-size) + +(define dc-backend% + (class default-dc-backend% + (init-field gtk + get-client-size) + + (define c #f) + + (define/override (get-cr) + (or c + (let ([w (g_object_get_window gtk)]) + (and w + (set! c (gdk_cairo_create w)) + c)))) + + (define/public (reset-dc-size) + (when (eq? 'windows (system-type)) + ;; FIXME: ensure that the dc is not in use + (as-entry + (lambda () + (when c + (cairo_destroy c) + (set! c #f)))))) + + (define/override (get-size) + (let-values ([(w h) (get-client-size)]) + (values (exact->inexact w) + (exact->inexact h)))) + + (super-new))) + +(define dc% + (dc-mixin dc-backend%)) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt new file mode 100644 index 00000000..6917c412 --- /dev/null +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -0,0 +1,28 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "../common/queue.rkt" + "frame.rkt") + +(provide dialog%) + +(defclass dialog% frame% + (super-new [is-dialog? #t]) + + (define close-sema #f) + + (define/override (direct-show on?) + (unless on? + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f))) + (super direct-show on?)) + + (define/override (show on?) + (if on? + (unless close-sema + (let ([s (make-semaphore)]) + (set! close-sema s) + (super show on?) + (yield s))) + (super show on?)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt new file mode 100644 index 00000000..5c35cc8f --- /dev/null +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -0,0 +1,170 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "client-window.rkt" + "widget.rkt" + "../common/queue.rkt") +(unsafe!) + +(provide frame%) + +;; ---------------------------------------- + +(define-gtk gtk_window_new (_fun _int -> _GtkWidget)) +(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) +(define-gtk gtk_fixed_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) +(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int)) + -> _void + -> (values w h))) +(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void)) +(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void)) + +(define (handle-delete gtk) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () + (when (send wx on-close) + (send wx direct-show #f)))))) +(define handle_delete + (function-ptr handle-delete + (_fun #:atomic? #t _GtkWidget -> _gboolean))) + +(define (handle-configure gtk) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () + (send wx on-size 0 0))) + #f)) +(define handle_configure + (function-ptr handle-configure + (_fun #:atomic? #t _GtkWidget -> _gboolean))) + +(define-cstruct _GdkEventWindowState ([type _int] + [window _GtkWindow] + [send_event _int8] + [changed_mask _int] + [new_window_state _int])) + + +(define-signal-handler connect-window-state "window-state-event" + (_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean) + (lambda (gtk evt) + (let ([wx (gtk->wx gtk)]) + (send wx on-window-state + (GdkEventWindowState-changed_mask evt) + (GdkEventWindowState-new_window_state evt))) + #f)) + +(define frame% + (class (client-size-mixin window%) + (init parent + label + x y w h + style) + (init [is-dialog? #f]) + + (inherit get-gtk set-size on-size + pre-on-char pre-on-event) + + (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) + (when (memq 'no-caption style) + (gtk_window_set_decorated gtk #f)) + (define vbox-gtk (gtk_vbox_new #f 0)) + (define panel-gtk (gtk_fixed_new #f 10)) + (gtk_container_add gtk vbox-gtk) + (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0) + (gtk_widget_show vbox-gtk) + (gtk_widget_show panel-gtk) + + (define/override (get-client-gtk) panel-gtk) + (define/override (get-window-gtk) gtk) + + (super-new [parent parent] + [gtk gtk] + [client-gtk panel-gtk] + [no-show? #t] + [add-to-parent? #f] + [extra-gtks (list panel-gtk)]) + + (set-size x y w h) + + (g_signal_connect gtk "delete_event" handle_delete) + ;; (g_signal_connect gtk "configure_event" handle_configure) + + (when label + (gtk_window_set_title gtk label)) + + (define/public (set-child-position child-gtk x y) + (gtk_fixed_move panel-gtk child-gtk x y)) + + (define/public (on-close) (void)) + + (define/public (set-menu-bar mb) + (send mb set-top-window this) + (let ([mb-gtk (send mb get-gtk)]) + (gtk_box_pack_start vbox-gtk mb-gtk #t #t 0) + (gtk_widget_show mb-gtk))) + + (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) + (void)) + + (define/override (get-size wb hb) + (let-values ([(w h) (gtk_window_get_size gtk)]) + (set-box! wb w) + (set-box! hb h))) + + (define/override (direct-show on?) + (super direct-show on?) + (register-frame-shown this on?)) + + (define/override (on-client-size w h) + (on-size w h)) + + (define/augment (is-enabled-to-root?) #t) + + (define/public (set-icon bm mask mode) (void)) ;; FIXME + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define/override (client-to-screen x y) + (void)) + + (def/public-unimplemented on-toolbar-click) + (def/public-unimplemented on-menu-click) + (def/public-unimplemented on-menu-command) + (def/public-unimplemented on-mdi-activate) + (def/public-unimplemented on-activate) + (def/public-unimplemented designate-root-frame) + (def/public-unimplemented system-menu) + + (define/public (set-modified mod?) (void)) + + (define/public (create-status-line) (void)) + (define/public (set-status-text s) (void)) + (def/public-unimplemented status-line-exists?) + + (define maximized? #f) + + (define/public (is-maximized?) + maximized?) + (define/public (maximize on?) + ((if on? gtk_window_maximize gtk_window_unmaximize) gtk)) + + (define/public (on-window-state changed value) + (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED)) + (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))) + + (def/public-unimplemented iconized?) + (def/public-unimplemented get-menu-bar) + (def/public-unimplemented iconize) + (define/public (set-title s) + (gtk_window_set_title gtk s)))) + diff --git a/collects/mred/private/wx/gtk/gauge.rkt b/collects/mred/private/wx/gtk/gauge.rkt new file mode 100644 index 00000000..6670f323 --- /dev/null +++ b/collects/mred/private/wx/gtk/gauge.rkt @@ -0,0 +1,55 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt") +(unsafe!) + +(provide gauge%) + +;; ---------------------------------------- + +(define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void)) + +(defclass gauge% item% + (init parent + label + rng + x y w h + style + font) + (inherit get-gtk set-auto-size) + + (super-new [parent parent] + [gtk (gtk_progress_bar_new #f)] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (set-auto-size) + + (define range rng) + (define value 0) + + (define/private (reset) + (gtk_progress_bar_set_fraction gtk + (if (zero? range) + 0.0 + (/ value range)))) + + (define/public (get-range) + range) + (define/public (set-range r) + (set! range r) + (set! value (min value r)) + (reset)) + + (define/public (set-value v) + (set! value v) + (reset)) + (define/public (get-value) + value)) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt new file mode 100644 index 00000000..ba5d78e0 --- /dev/null +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -0,0 +1,11 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide gl-context%) + +(defclass gl-context% object% + (def/public-unimplemented call-as-current) + (def/public-unimplemented swap-buffers) + (def/public-unimplemented ok?) + (super-new)) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt new file mode 100644 index 00000000..b22859db --- /dev/null +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -0,0 +1,50 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "window.rkt" + "client-window.rkt" + "panel.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) + +(provide group-panel%) + +(define-gtk gtk_frame_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define-gtk gtk_frame_set_label (_fun _GtkWidget _string -> _void)) + +(define group-panel% + (class (client-size-mixin (panel-mixin window%)) + (init parent + x y w h + style + label) + + (inherit set-size set-auto-size get-gtk) + + (define gtk (gtk_frame_new label)) + (define client-gtk (gtk_fixed_new)) + (gtk_container_add gtk client-gtk) + (gtk_widget_show client-gtk) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + + (define/public (set-label s) + (gtk_frame_set_label gtk s)) + + (define/override (get-client-gtk) client-gtk) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move client-gtk child-gtk x y) + (super set-child-size child-gtk x y w h)))) diff --git a/collects/mred/private/wx/gtk/init.rkt b/collects/mred/private/wx/gtk/init.rkt new file mode 100644 index 00000000..4effb240 --- /dev/null +++ b/collects/mred/private/wx/gtk/init.rkt @@ -0,0 +1,12 @@ +#lang scheme/base +(require scheme/foreign + "utils.rkt" + "types.rkt" + "queue.rkt") +(unsafe!) + +(define-gtk gtk_init (_fun (_ptr io _int) (_ptr io _pointer) -> _void)) + +(gtk_init 0 #f) +(define pump-thread (gtk-start-event-pump)) + diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt new file mode 100644 index 00000000..556f5c94 --- /dev/null +++ b/collects/mred/private/wx/gtk/item.rkt @@ -0,0 +1,23 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide item%) + +(defclass item% window% + (inherit get-client-gtk) + + (super-new) + + (let ([client-gtk (get-client-gtk)]) + (connect-focus client-gtk) + (connect-key-and-mouse client-gtk)) + + (def/public-unimplemented set-label) + (def/public-unimplemented get-label) + (def/public-unimplemented command)) + + + + diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt new file mode 100644 index 00000000..99afa09c --- /dev/null +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -0,0 +1,67 @@ +#lang scheme/base + +(provide map-key-code) + +(define (map-key-code v) + (hash-ref + #hash((#xff08 . #\backspace) + (#xff09 . #\tab) + (#xff0a . #\newline) + (#xff0d . #\return) + (#xff1b . #\u1B); escape + (#xff50 . home) + (#xff51 . left) + (#xff52 . up) + (#xff53 . right) + (#xff54 . down) + (#xff55 . prior) + (#xff56 . next) + (#xff57 . end) + (#xff80 . #\space) ; keypad + (#xff89 . #\tab) ; keypad + (#xff8d . #\u3) ; enter + (#xff91 . f1) + (#xff92 . f2) + (#xff93 . f3) + (#xff94 . f4) + (#xff95 . home) ; keypad + (#xff96 . left) ; keypd + (#xff97 . up) ; keypad + (#xff98 . right) ; keypad + (#xff99 . down) ; keypad + (#xff9a . prior) ; keypad + (#xff9b . next) ; keypad + (#xff9c . end) ; keypad + (#xff9e . insert) ; keypad + (#xff9f . #\rubout) ; keypad + (#xffaa . multiply) + (#xffab . add) + (#xffad . subtract) + (#xffaf . divide) + (#xffb0 . numpad0) + (#xffb1 . numpad1) + (#xffb2 . numpad2) + (#xffb3 . numpad3) + (#xffb4 . numpad4) + (#xffb5 . numpad5) + (#xffb6 . numpad6) + (#xffb7 . numpad7) + (#xffb8 . numpad8) + (#xffb9 . numpad9) + (#xffbe . f1) + (#xffbf . f2) + (#xffc0 . f3) + (#xffc1 . f4) + (#xffc2 . f5) + (#xffc3 . f6) + (#xffc4 . f7) + (#xffc5 . f8) + (#xffc6 . f9) + (#xffc7 . f10) + (#xffc8 . f11) + (#xffc9 . f12) + (#xffca . f13) + (#xffcb . f14) + (#xffcc . f15)) + v + #f)) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt new file mode 100644 index 00000000..966b361b --- /dev/null +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -0,0 +1,180 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "../common/event.rkt") +(unsafe!) + +(provide list-box%) + +;; ---------------------------------------- + +(define-cstruct _GtkTreeIter ([stamp _int] + [user_data _pointer] + [user_data2 _pointer] + [user_data3 _pointer])) + +(define _GtkListStore (_cpointer 'GtkListStore)) +(define _GtkCellRenderer (_cpointer 'GtkCellRenderer)) +(define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn) + +(define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) +(define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) + +(define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore)) +(define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) +(define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) +(define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) +(define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer)) +(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) +(define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) +(define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) + +(define _GList (_cpointer 'List)) +(define-gdk g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) +(define-gdk g_list_free (_fun _GList -> _void)) +(define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) +(define-gtk gtk_tree_path_free (_fun _pointer -> _void)) +(define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) + +(define-gtk gtk_tree_view_get_visible_range (_fun _GtkWidget [sp : (_ptr o _pointer)] [ep : (_ptr o _pointer)] + -> [ok? : _gboolean] + -> (values (if ok? sp #f) (if ok? ep #f)))) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx queue-changed)))) + +(defclass list-box% item% + (init parent cb + label kind x y w h + choices style + font label-font) + (inherit get-gtk set-auto-size is-window-enabled?) + + (define items choices) + (define data (map (lambda (c) (box #f)) choices)) + + (define store (gtk_list_store_new 1 G_TYPE_STRING)) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (for ([s (in-list choices)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1))) + + (define column + (let ([renderer (gtk_cell_renderer_text_new)]) + (gtk_tree_view_column_new_with_attributes + "column" + renderer + "text" + 0 + #f))) + + (define gtk (gtk_scrolled_window_new #f #f)) + (gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS) + + (define client-gtk + (let* ([client-gtk (gtk_tree_view_new_with_model store)]) + (gtk_tree_view_set_headers_visible client-gtk #f) + (gtk_tree_view_append_column client-gtk column) + client-gtk)) + + (gtk_container_add gtk client-gtk) + (gtk_widget_show client-gtk) + + (define selection + (gtk_tree_view_get_selection client-gtk)) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks (list client-gtk selection)] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + + (connect-changed selection) + + (define/override (get-client-gtk) client-gtk) + + (define callback cb) + (define/public (queue-changed) + ;; Called from event-handling thread + (queue-window-event + this + (lambda () + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)]))))) + + (def/public-unimplemented get-label-font) + (def/public-unimplemented set-string) + (def/public-unimplemented set-first-visible-item) + (def/public-unimplemented set) + + (define/public (get-selections) + (as-entry + (lambda () + (let ([list (gtk_tree_selection_get_selected_rows selection #f)]) + (if list + (let ([v null]) + (g_list_foreach list + (lambda (t) + (set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int) + v))) + #f) + (g_list_foreach list gtk_tree_path_free #f) + (g_list_free list) + (reverse v)) + null))))) + (define/public (get-selection) + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l)))) + + (define/private (get-visible-range) + (as-entry + (lambda () + (let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)]) + (begin0 + (values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0) + (if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0)) + (when sp (gtk_tree_path_free sp)) + (when ep (gtk_tree_path_free ep))))))) + + (define/public (get-first-item) + (let-values ([(start end) (get-visible-range)]) + start)) + (define/public (number-of-visible-items) + (let-values ([(start end) (get-visible-range)]) + (add1 (- end start)))) + + (define/public (number) (length items)) + + (define/public (set-data i v) (set-box! (list-ref data i) v)) + (define/public (get-data i) (unbox (list-ref data i))) + + (def/public-unimplemented selected?) + (def/public-unimplemented set-selection) + (def/public-unimplemented select) + (def/public-unimplemented delete) + (def/public-unimplemented clear) + + (public [append* append]) + (define (append* s [v #f]) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)))) + + diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt new file mode 100644 index 00000000..dc59e963 --- /dev/null +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -0,0 +1,85 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "../cocoa/freeze.rkt" + "widget.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) + +(provide menu-bar% + gtk_menu_item_new_with_mnemonic + gtk_menu_shell_append + fixup-mneumonic) + +(define-gtk gtk_menu_bar_new (_fun -> _GtkWidget)) +(define-gtk gtk_menu_shell_append (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) + +(define (fixup-mneumonic title) + (regexp-replace* + "&&" + (regexp-replace* + #rx"&([^&])" + (regexp-replace* + #rx"_" + (regexp-replace #rx"\t.*$" title "") + "__") + "_\\1") + "&")) + +(define-signal-handler connect-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (let ([frame (send wx get-top-window)]) + (constrained-reply (send wx get-eventspace) + (lambda () (send frame on-menu-click) #f) + #t))))) + +(defclass menu-bar% widget% + (define menus null) + + (define gtk (gtk_menu_bar_new)) + (super-new [gtk gtk]) + + (connect-button-press gtk) + + (define/public (get-gtk) gtk) + + (define top-wx #f) + (define/public (set-top-window top) + (set! top-wx top)) + (define/public (get-top-window) + top-wx) + + (def/public-unimplemented set-label-top) + (def/public-unimplemented number) + (def/public-unimplemented enable-top) + + (define/public (delete which pos) + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) + (gtk_container_remove gtk (caar menus)) + (gtk_menu_item_set_submenu (caar menus) #f) + (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + pos))])))) + + (public [append-menu append]) + (define (append-menu menu title) + (send menu set-parent this) + (let ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]) + (set! menus (append menus (list (list item menu title)))) + (let ([gtk (send menu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item gtk)) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item)))) diff --git a/collects/mred/private/wx/gtk/menu-item.rkt b/collects/mred/private/wx/gtk/menu-item.rkt new file mode 100644 index 00000000..afe240e0 --- /dev/null +++ b/collects/mred/private/wx/gtk/menu-item.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide menu-item%) + +(defclass menu-item% object% + (define/public (id) this) + (super-new)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt new file mode 100644 index 00000000..9335040e --- /dev/null +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -0,0 +1,165 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "widget.rkt" + "window.rkt" + "../../syntax.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "menu-bar.rkt") +(unsafe!) + +(provide menu%) + +(define-gtk gtk_menu_new (_fun -> _GtkWidget)) +(define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_separator_menu_item_new (_fun -> _GtkWidget)) +(define-gdk gdk_unicode_to_keyval (_fun _uint32 -> _uint)) +(define-gtk gtk_menu_item_set_accel_path (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_accel_map_add_entry (_fun _string _uint _int -> _void)) +(define-gtk gtk_check_menu_item_set_active (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_menu_item_set_label (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) + +(define-signal-handler connect-menu-item-activate "activate" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx do-on-select)))) + +(define menu-item-handler% + (class widget% + (init gtk) + (init-field menu + menu-item) + (super-new [gtk gtk]) + + (connect-menu-item-activate gtk) + + (define/public (get-item) menu-item) + + (define/public (do-on-select) + (let ([top (send menu get-top-parent)]) + (when top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))))) + + (define/public (on-select) + (send menu on-select-item menu-item)))) + +(defclass menu% widget% + (init label + callback + font) + + (define gtk (gtk_menu_new)) + (define/public (get-gtk) gtk) + + (super-new [gtk gtk]) + + (define items null) + + (define parent #f) + (define/public (set-parent p) + (set! parent p)) + (define/public (get-top-parent) + ;; Maybe be called in Gtk event-handler thread + (and parent + (if (parent . is-a? . menu%) + (send parent get-top-parent) + (send parent get-top-window)))) + + (define/private (adjust-shortcut item-gtk title) + (cond + [(regexp-match #rx"\tCtrl[+](.)$" title) + => (lambda (m) + (let ([code (gdk_unicode_to_keyval + (char->integer + (string-ref (cadr m) 0)))]) + (unless (zero? code) + (let ([accel-path (format "/Thing/~a" title)]) + (gtk_accel_map_add_entry accel-path + code + GDK_CONTROL_MASK) + (gtk_menu_item_set_accel_path item-gtk accel-path)))))])) + + (public [append-item append]) + (define (append-item i label help-str chckable?) + (let* ([item-gtk ((if chckable? + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + (fixup-mneumonic label))] + [item (new menu-item-handler% + [gtk item-gtk] + [menu this] + [menu-item i])]) + (set! items (append items (list (list item item-gtk label chckable?)))) + (adjust-shortcut item-gtk label) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk))) + + (define/public (append-separator) + (let ([item-gtk (gtk_separator_menu_item_new)]) + (set! items (append items (list (list #f item-gtk #f #f)))) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk))) + + (def/public-unimplemented select) + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + + (def/public-unimplemented set-help-string) + (def/public-unimplemented number) + + (define/private (find-gtk item) + (for/or ([i items]) + (and (car i) + (eq? (send (car i) get-item) item) + (cadr i)))) + + (define/public (set-label item str) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_menu_item_set_label gtk str)))) + + (define/public (enable item on?) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_widget_set_sensitive gtk on?)))) + + (define/public (check item on?) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_check_menu_item_set_active gtk on?)))) + + (define/public (checked? item) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_check_menu_item_get_active gtk)))) + + (define/public (delete-by-position pos) + (set! items + (let loop ([items items] + [pos pos]) + (cond + [(null? items) null] + [(zero? pos) + (gtk_container_remove gtk (cadar items)) + (cdr items)] + [else (cons (car items) + (loop (cdr items) (sub1 pos)))])))) + + (define/public (delete item) + (set! items + (let loop ([items items]) + (cond + [(null? items) null] + [(eq? (send (caar items) get-item) item) + (gtk_container_remove gtk (cadar items)) + (cdr items)] + [else (cons (car items) + (loop (cdr items)))]))))) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt new file mode 100644 index 00000000..011a59b0 --- /dev/null +++ b/collects/mred/private/wx/gtk/message.rkt @@ -0,0 +1,39 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "pixbuf.rkt") +(unsafe!) + +(provide message%) + +;; ---------------------------------------- + +(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) + +(defclass message% item% + (init parent label + x y + style font) + (inherit set-auto-size get-gtk) + + (super-new [parent parent] + [gtk (if (or (string? label) + (not label)) + (gtk_label_new (or label "")) + (if (symbol? label) + (gtk_label_new (format "<~a>" label)) + (gtk_image_new_from_pixbuf + (bitmap->pixbuf label))))] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + + (define/override (set-label s) + (gtk_label_set_text (get-gtk) s)) + + (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt new file mode 100644 index 00000000..3f6bda3e --- /dev/null +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -0,0 +1,47 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "window.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) + +(provide panel% + panel-mixin) + +; (define-gtk gtk_alignment_new (_fun _gfloat _gfloat _gfloat _gfloat -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define (panel-mixin %) + (class % + (define lbl-pos 'vertical) + (super-new) + + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (def/public-unimplemented on-paint) + (define/public (set-item-cursor x y) (void)) + (def/public-unimplemented get-item-cursor))) + +(define panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) + + (inherit set-size get-gtk) + + (super-new [parent parent] + [gtk (gtk_fixed_new)] ; (gtk_alignment_new 0.0 0.0 1.0 1.0)] + [no-show? (memq 'deleted style)]) + + (define gtk (get-gtk)) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move gtk child-gtk x y) + (super set-child-size child-gtk x y w h)))) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt new file mode 100644 index 00000000..42cca9e2 --- /dev/null +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -0,0 +1,53 @@ +#lang racket +(require racket/class + ffi/unsafe + racket/draw + "../common/bstr.rkt" + "utils.rkt" + "types.rkt" + (only-in '#%foreign ffi-callback)) + +(provide _GdkPixbuf + bitmap->pixbuf + gtk_image_new_from_pixbuf) + +(define _GdkPixbuf (_cpointer 'GdkPixbuf)) + +(define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget)) +(define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data + _int ; 0 =RGB + _gboolean ; has_alpha? + _int ; bits_per_sample + _int ; width + _int ; height + _int ; rowstride + _fpointer ; destroy + _pointer ; destroy data + -> _GdkPixbuf)) +(define free-it (ffi-callback free + (list _pointer) + _void + #f + #t)) + +(define (bitmap->pixbuf bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [str (make-bytes (* w h 4) 255)]) + (send bm get-argb-pixels 0 0 w h str #f) + (let ([mask-bm (send bm get-loaded-mask)]) + (when mask-bm + (send mask-bm get-argb-pixels 0 0 w h str #t))) + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 1)]) + (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) + (for ([i (in-range 0 (* w h 4) 4)]) + (bytes-set! rgba (+ i 3) (bytes-ref str i))) + (gdk_pixbuf_new_from_data rgba + 0 + #t + 8 + w + h + (* w 4) + free-it + #f)))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt new file mode 100644 index 00000000..bec2c5ee --- /dev/null +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -0,0 +1,108 @@ +#lang scheme/base +(require "init.rkt" + "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "gl-context.rkt" + "group-box.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-group.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide platform-values) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + gl-context% + group-box% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-group% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + begin-busy-cursor + is-busy? + end-busy-cursor + has-x-selection? + hide-cursor + bell + display-size + display-origin + get-resource + write-resource + flush-display + fill-private-color + cancel-quit + get-control-font-size + key-symbol-to-integer + draw-tab-base + draw-tab + set-combo-box-font + get-double-click-time + run-printout + end-refresh-sequence + begin-refresh-sequence + file-creator-and-type + send-event + set-executer + set-dialogs + location->window + set-menu-tester + in-atomic-region + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + get-top-level-windows + find-graphical-system-path + check-for-break + play-sound + get-panel-background + get-font-from-user + get-color-from-user + application-pref-handler + application-about-handler + application-quit-handler + application-file-handler + special-option-key + special-control-key)) diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt new file mode 100644 index 00000000..38819ef7 --- /dev/null +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require racket/class + racket/draw/dc) + +(provide printer-dc%) + +(define dc-backend% + (class default-dc-backend% + (init [parent #f]) + + (super-new))) + +(define printer-dc% + (dc-mixin dc-backend%)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt new file mode 100644 index 00000000..99b26a6f --- /dev/null +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -0,0 +1,126 @@ +#lang racket/base +(require ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + racket/class + racket/draw + "types.rkt" + "utils.rkt" + "../common/handlers.rkt") + +(provide + special-control-key + special-option-key + application-file-handler + application-quit-handler + application-about-handler + application-pref-handler + get-color-from-user + get-font-from-user + get-panel-background + play-sound + check-for-break + find-graphical-system-path + get-top-level-windows + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + in-atomic-region + set-menu-tester + location->window + set-dialogs + set-executer + send-event + file-creator-and-type + begin-refresh-sequence + end-refresh-sequence + run-printout + get-double-click-time + set-combo-box-font + draw-tab + draw-tab-base + key-symbol-to-integer + get-control-font-size + cancel-quit + fill-private-color + flush-display + write-resource + get-resource + display-origin + display-size + bell + hide-cursor + end-busy-cursor + is-busy? + begin-busy-cursor + get-display-depth + is-color-display? + file-selector + id-to-menu-item + get-the-x-selection + get-the-clipboard + show-print-setup + can-show-print-setup?) + + +(define-unimplemented special-control-key) +(define-unimplemented special-option-key) +(define-unimplemented get-color-from-user) +(define-unimplemented get-font-from-user) +(define (get-panel-background) (make-object color% "gray")) +(define-unimplemented play-sound) +(define-unimplemented check-for-break) +(define-unimplemented find-graphical-system-path) +(define (get-top-level-windows) null) +(define (register-collecting-blit . args) (void)) +(define (unregister-collecting-blit . args) (void)) +(define (shortcut-visible-in-label? [mbar? #f]) #t) +(define-unimplemented in-atomic-region) +(define (set-menu-tester proc) (void)) +(define-unimplemented location->window) +(define (set-dialogs . args) (void)) +(define (set-executer e) (void)) +(define-unimplemented send-event) +(define-unimplemented file-creator-and-type) +(define (begin-refresh-sequence) (void)) +(define (end-refresh-sequence) (void)) +(define-unimplemented run-printout) +(define (get-double-click-time) 250) +(define (set-combo-box-font f) (void)) +(define-unimplemented draw-tab) +(define-unimplemented draw-tab-base) +(define-unimplemented key-symbol-to-integer) +(define (get-control-font-size) 10) ;; FIXME +(define-unimplemented cancel-quit) +(define-unimplemented fill-private-color) +(define (flush-display) (void)) +(define-unimplemented write-resource) +(define-unimplemented get-resource) + +(define _GdkScreen (_cpointer 'GdkScreen)) +(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) +(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) +(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) + +(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) +(define (display-size w h all?) + (let ([s (gdk_screen_get_default)]) + (set-box! w (gdk_screen_get_width s)) + (set-box! h (gdk_screen_get_height s)))) +(define (get-display-depth) 32) + +(define-unimplemented bell) +(define (hide-cursor) (void)) + +(define busy-count 0) +(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count))))) +(define (is-busy?) (positive? busy-count)) +(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) + +(define-unimplemented is-color-display?) +(define-unimplemented file-selector) +(define (id-to-menu-item i) i) +(define-unimplemented get-the-x-selection) +(define-unimplemented get-the-clipboard) +(define-unimplemented show-print-setup) +(define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt new file mode 100644 index 00000000..a37830bf --- /dev/null +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -0,0 +1,133 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "utils.rkt" + "types.rkt" + racket/draw/lock + "../common/queue.rkt" + "../cocoa/freeze.rkt" + "const.rkt") + +(provide gtk-start-event-pump + + set-widget-hook! + + ;; from common/queue: + current-eventspace + queue-event + yield) + +;; ------------------------------------------------------------ +;; Gtk event pump + +(define-gtk gtk_init (_fun _int _pointer -> _void)) +(gtk_init 0 #f) + +(define-gtk gtk_events_pending (_fun -> _gboolean)) +(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) + +(define _GMainContext (_cpointer 'GMainContext)) +(define _GdkEvent (_cpointer 'GdkEvent)) + +(define-cstruct _GPollFD ([fd _int] + [events _short] + [revents _short])) + +(define-glib g_main_context_default (_fun -> _GMainContext)) +(define-glib g_main_context_query (_fun _GMainContext + _int + _pointer + _GPollFD-pointer + _int + -> _int)) + +(define-gdk gdk_event_handler_set (_fun (_fun _GdkEvent _pointer -> _void) + _pointer + (_fun _pointer -> _void) + -> _void)) +(define-gdk gdk_event_copy (_fun _GdkEvent -> _GdkEvent)) +(define-gdk gdk_event_free (_fun _GdkEvent -> _void)) +(define-gtk gtk_main_do_event (_fun _GdkEvent -> _void)) +(define-gtk gtk_get_event_widget (_fun _GdkEvent -> (_or-null _GtkWidget))) + +(define poll-fd-count 1) +(define poll-fds (make-GPollFD 0 0 0)) +(define timeout (malloc _int)) + +;; These are OS-specific, but they tend to be the same across OSes: +(define POLLIN #x1) +(define POLLOUT #x4) +(define POLLERR #x8) +(define POLLHUP #x10) + +(define-mz scheme_get_fdset (_fun _pointer _int -> _pointer)) +(define-mz scheme_fdset (_fun _pointer _int -> _void)) + +(define (install-wakeup fds) + (pre-event-sync #t) + (let ([n (g_main_context_query (g_main_context_default) + #x7FFFFFFF ; max-int, hopefully + timeout + poll-fds + poll-fd-count)]) + ;; FIXME: use the `timeout' result + (if (n . > . poll-fd-count) + (begin + (set! poll-fds (malloc _GPollFD n)) + (set! poll-fd-count n) + (install-wakeup fds)) + (for ([i (in-range n)]) + (let* ([gfd (ptr-ref poll-fds _GPollFD i)] + [fd (GPollFD-fd gfd)] + [events (GPollFD-events gfd)]) + (when (not (zero? (bitwise-and events POLLIN))) + (scheme_fdset (scheme_get_fdset fds 0) fd)) + (when (not (zero? (bitwise-and events POLLOUT))) + (scheme_fdset (scheme_get_fdset fds 1) fd)) + (when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP)))) + (scheme_fdset (scheme_get_fdset fds 2) fd))))))) + +(set-check-queue! gtk_events_pending) +(set-queue-wakeup! install-wakeup) + +(define widget-hook (lambda (gtk) #f)) +(define (set-widget-hook! proc) (set! widget-hook proc)) + +(define (event-dispatch evt ignored) + (let* ([gtk (gtk_get_event_widget evt)] + [wx (and gtk (widget-hook gtk))]) + (cond + [(and (= (ptr-ref evt _int) GDK_EXPOSE) + wx + (send wx direct-update?)) + (gtk_main_do_event evt)] + [(and wx (send wx get-eventspace)) + => (lambda (e) + (let ([evt (gdk_event_copy evt)]) + (queue-event e (lambda () + (as-entry (lambda () + (call-with-frozen-stack + (lambda () + (gtk_main_do_event evt) + (gdk_event_free evt)))))))))] + [else + (gtk_main_do_event evt)]))) +(define (uninstall ignored) + (printf "uninstalled!?\n")) + +(gdk_event_handler_set event-dispatch + #f + uninstall) + +(define (dispatch-all-ready) + (pre-event-sync #f) + (when (gtk_events_pending) + (gtk_main_iteration_do #f) + (dispatch-all-ready))) + +(define (gtk-start-event-pump) + (thread (lambda () + (let loop () + (sync queue-evt) + (as-entry dispatch-all-ready) + (loop))))) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt new file mode 100644 index 00000000..f289e429 --- /dev/null +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -0,0 +1,113 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "widget.rkt" + "window.rkt" + "pixbuf.rkt" + "../common/event.rkt" + "../../lock.rkt") +(unsafe!) + +(provide radio-box%) + +;; ---------------------------------------- + +(define _GSList (_cpointer/null 'GSList)) + +(define-gtk gtk_radio_button_new_with_label (_fun _GSList _string -> _GtkWidget)) +(define-gtk gtk_radio_button_new (_fun _GSList -> _GtkWidget)) +(define-gtk gtk_radio_button_get_group (_fun _GtkWidget -> _GSList)) +(define-gtk gtk_radio_button_set_group (_fun _GtkWidget _GSList -> _void)) +(define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) + +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx queue-clicked)))) + +(defclass radio-box% item% + (init parent cb label + x y w h + labels + val + style + font) + (inherit set-auto-size + on-set-focus) + + (define gtk (gtk_vbox_new #f 0)) + (define radio-gtks (for/list ([lbl (in-list labels)]) + (let ([radio-gtk (cond + [(string? lbl) + (gtk_radio_button_new_with_label #f lbl)] + [(send lbl ok?) + (let ([radio-gtk (gtk_radio_button_new #f)] + [image-gtk (gtk_image_new_from_pixbuf + (bitmap->pixbuf lbl))]) + (gtk_container_add radio-gtk image-gtk) + (gtk_widget_show image-gtk) + radio-gtk)] + [else + (gtk_radio_button_new_with_label #f "")])]) + (gtk_box_pack_start gtk radio-gtk #t #t 0) + (gtk_widget_show radio-gtk) + radio-gtk))) + (for ([radio-gtk (in-list (cdr radio-gtks))]) + (let ([g (gtk_radio_button_get_group (car radio-gtks))]) + (gtk_radio_button_set_group radio-gtk g))) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks radio-gtks] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + (for ([radio-gtk (in-list (cdr radio-gtks))]) + (connect-clicked radio-gtk)) + (for ([radio-gtk (in-list radio-gtks)]) + (connect-key-and-mouse radio-gtk) + (connect-focus radio-gtk)) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))) + (define no-clicked? #f) + (define/public (queue-clicked) + (unless no-clicked? + (queue-window-event this (lambda () (clicked))))) + + (define/public (button-focus i) + (if (= i -1) + (or (for/or ([radio-gtk (in-list radio-gtks)] + [i (in-naturals)]) + (and (gtk_widget_is_focus radio-gtk) + i)) + 0) + (gtk_widget_grab_focus (list-ref radio-gtks i)))) + (define/override (set-focus) + (button-focus (max 0 (set-selection)))) + (define/public (set-selection i) + (as-entry + (lambda () + (set! no-clicked? #t) + (gtk_toggle_button_set_active (list-ref radio-gtks i) #t) + (set! no-clicked? #f)))) + + (define/public (get-selection) + (or (for/or ([radio-gtk (in-list radio-gtks)] + [i (in-naturals)]) + (and (gtk_toggle_button_get_active radio-gtk) + i)) + -1)) + + (define count (length labels)) + (define/public (number) count)) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt new file mode 100644 index 00000000..337c043e --- /dev/null +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -0,0 +1,68 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "../common/event.rkt") +(unsafe!) + +(provide slider%) + +;; ---------------------------------------- + +(define-gtk gtk_hscale_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_vscale_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_range_set_range (_fun _GtkWidget _double* _double* -> _void)) +(define-gtk gtk_range_set_increments (_fun _GtkWidget _double* _double* -> _void)) +(define-gtk gtk_range_set_value (_fun _GtkWidget _double* -> _void)) +(define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) + +(define-signal-handler connect-changed "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx queue-changed)))) + +(defclass slider% item% + (init parent cb + label + val lo hi + x y w + style + font) + (inherit get-gtk set-auto-size) + + (super-new [parent parent] + [gtk (if (memq 'vertical style) + (gtk_vscale_new #f) + (gtk_hscale_new #f))] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (gtk_range_set_range gtk lo hi) + (gtk_range_set_increments gtk 1.0 1.0) + (gtk_range_set_value gtk val) + + (set-auto-size) + + (connect-changed gtk) + + (define callback cb) + (define/public (queue-changed) + ;; Called in event-dispatch thread + (gtk_range_set_value gtk (floor (gtk_range_get_value gtk))) + (queue-window-event + this + (lambda () + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)]))))) + + (define/public (set-value v) + (gtk_range_set_value gtk v)) + (define/public (get-value) + (inexact->exact (floor (gtk_range_get_value gtk))))) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt new file mode 100644 index 00000000..e55ff7cb --- /dev/null +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -0,0 +1,102 @@ +#lang scheme/base +(require scheme/class + scheme/foreign + "../../syntax.rkt" + "window.rkt" + "client-window.rkt" + "utils.rkt" + "panel.rkt" + "types.rkt" + "widget.rkt") +(unsafe!) + +(provide tab-panel%) + +(define-gtk gtk_notebook_new (_fun -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) +(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) + +(define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) + +(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void)) + +(define-struct page (bin-gtk label-gtk)) + +(define-signal-handler connect-changed "switch-page" + (_fun _GtkWidget _pointer _int -> _void) + (lambda (gtk ignored i) + (let ([wx (gtk->wx gtk)]) + (send wx page-changed i)))) + +(define tab-panel% + (class (client-size-mixin (panel-mixin window%)) + (init parent + x y w h + style + labels) + + (inherit set-size set-auto-size get-gtk) + + (define gtk (gtk_notebook_new)) + ;; Reparented so that it's always in the current page's bin: + (define client-gtk (gtk_fixed_new)) + + (define empty-bin-gtk (gtk_hbox_new #f 0)) + (define current-bin-gtk #f) + + (define (select-bin bin-gtk) + (set! current-bin-gtk bin-gtk) + (gtk_box_pack_start bin-gtk client-gtk #t #t 0)) + + (define pages + (for/list ([lbl labels]) + (let ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new lbl)]) + (gtk_notebook_append_page gtk bin-gtk label-gtk) + (gtk_widget_show bin-gtk) + (make-page bin-gtk label-gtk)))) + + (if (null? pages) + (begin + (select-bin empty-bin-gtk) + (gtk_notebook_append_page gtk empty-bin-gtk #f) + (gtk_widget_show empty-bin-gtk)) + (begin + (select-bin (page-bin-gtk (car pages))))) + (gtk_widget_show client-gtk) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + + (define/public (page-changed i) + (let ([bin-gtk (page-bin-gtk (list-ref pages i))]) + (gtk_widget_ref client-gtk) + (gtk_container_remove current-bin-gtk client-gtk) + (select-bin bin-gtk) + (gtk_widget_unref client-gtk))) + (connect-changed gtk) + + (define/override (get-client-gtk) client-gtk) + + (define/public (set-label i str) + (gtk_label_set_text (page-label-gtk (list-ref pages i)) str)) + + (define/public (set-selection i) + (gtk_notebook_set_current_page gtk i)) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move client-gtk child-gtk x y) + (super set-child-size child-gtk x y w h)))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt new file mode 100644 index 00000000..62cb6be1 --- /dev/null +++ b/collects/mred/private/wx/gtk/types.rkt @@ -0,0 +1,73 @@ +#lang scheme/base +(require scheme/foreign) +(unsafe!) + +(provide _GdkWindow + _GtkWidget _GtkWindow + _gpointer + _GdkEventExpose + + _fnpointer + _gboolean + _gfloat + + _GdkEventButton _GdkEventButton-pointer + (struct-out GdkEventButton) + _GdkEventKey _GdkEventKey-pointer + (struct-out GdkEventKey) + _GdkEventMotion _GdkEventMotion-pointer + (struct-out GdkEventMotion)) + +(define _GdkWindow (_cpointer/null 'GdkWindow)) + +(define _GtkWidget (_cpointer 'GtkWidget)) +(define _GtkWindow _GtkWidget) + +(define _gpointer _GtkWidget) +(define _GdkEventExpose (_cpointer 'GdkEventExpose)) + +(define _GdkDevice (_cpointer 'GdkDevice)) + +(define _fnpointer _pointer) ; a function pointer that can be NULL +(define _gboolean _bool) +(define _gfloat _float) +(define _GdkEventType _int) + +(define-cstruct _GdkEventButton ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [axes _pointer] ; array of _double + [state _uint] + [button _uint] + [device _GdkDevice] + [x_root _double] + [y_root _double])) + + +(define-cstruct _GdkEventKey ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [state _uint] + [keyval _uint] + [length _int] + [string _pointer] ; do not use + [hardware_keycode _uint16] + [group _ubyte] + [is_modifier _byte])) ; just 1 bit + +(define-cstruct _GdkEventMotion ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [axes _pointer] + [state _uint] + [is_hint _int16] + [device _GdkDevice] + [x_root _double] + [y_root _double])) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt new file mode 100644 index 00000000..dda5ba82 --- /dev/null +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -0,0 +1,117 @@ +#lang scheme/base +(require ffi/unsafe + ffi/unsafe/define + "../common/utils.rkt" + "types.rkt") + +(provide define-gtk + define-gdk + define-gobj + define-gio + define-glib + define-gdk_pixbuf + define-mz + + g_object_ref + g_object_unref + + g_object_set_data + g_object_get_data + g_signal_connect + + (rename-out [g_object_get g_object_get_window]) + + get-gtk-object-flags + set-gtk-object-flags! + + define-signal-handler) + +(define gdk-lib + (case (system-type) + [(windows) + (ffi-lib "libatk-1.0-0") + (ffi-lib "libgio-2.0-0") + (ffi-lib "libgdk_pixbuf-2.0-0") + (ffi-lib "libgdk-win32-2.0-0")] + [else (ffi-lib "libgdk-x11-2.0" '("0"))])) +(define gobj-lib + (case (system-type) + [(windows) + (ffi-lib "libgobject-2.0-0")] + [else gdk-lib])) +(define glib-lib + (case (system-type) + [(windows) + (ffi-lib "libglib-2.0-0")] + [else gdk-lib])) +(define gio-lib + (case (system-type) + [(windows) + (ffi-lib "libgio-2.0-0")] + [else gdk-lib])) +(define gmodule-lib + (case (system-type) + [(windows) + (ffi-lib "libgmodule-2.0-0")] + [else gdk-lib])) +(define gdk_pixbuf-lib + (case (system-type) + [(windows) + (ffi-lib "libgdk_pixbuf-2.0-0")] + [else gdk-lib])) +(define gtk-lib + (case (system-type) + [(windows) + (ffi-lib "libgtk-win32-2.0-0")] + [else (ffi-lib "libgtk-x11-2.0" '("0"))])) + +(define-ffi-definer define-gtk gtk-lib) +(define-ffi-definer define-gobj gobj-lib) +(define-ffi-definer define-gio gio-lib) +(define-ffi-definer define-glib glib-lib) +(define-ffi-definer define-gmodule gmodule-lib) +(define-ffi-definer define-gdk gdk-lib) +(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) + +(define-gobj g_object_ref (_fun _GtkWidget -> _void)) +(define-gobj g_object_unref (_fun _GtkWidget -> _void)) + +(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) +(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) + +(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer (_pointer = #f) _fnpointer _int -> _ulong)) +(define (g_signal_connect obj s proc) + (g_signal_connect_data obj s proc #f 0)) + +(define-gobj g_object_get (_fun _GtkWidget (_string = "window") + [w : (_ptr o _GdkWindow)] + (_pointer = #f) -> _void -> w)) + +;; This seems dangerous, since the shape of GtkObject is not +;; documented. But it seems to be the only way to get and set +;; flags. +(define-cstruct _GtkObject ([type-instance _pointer] + [ref_count _uint] + [qdata _pointer] + [flags _uint32])) +(define (get-gtk-object-flags gtk) + (GtkObject-flags (cast gtk _pointer _GtkObject-pointer))) +(define (set-gtk-object-flags! gtk v) + (set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)) + +(define-gtk gtk_rc_parse (_fun _path -> _void)) +(define-gmodule g_module_open (_fun _path _int -> _pointer)) +(when (eq? 'windows (system-type)) + (gtk_rc_parse (build-path (collection-path "scheme") 'up 'up "lib" "gtkrc"))) + +(define-syntax-rule (define-signal-handler + connect-name + signal-name + (_fun . args) + proc) + (begin + (define handler-proc proc) + (define handler_function + (function-ptr handler-proc (_fun #:atomic? #t . args))) + (define (connect-name gtk) + (g_signal_connect gtk signal-name handler_function)))) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt new file mode 100644 index 00000000..cc3cf704 --- /dev/null +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -0,0 +1,54 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "queue.rkt" + "utils.rkt" + "types.rkt") +(unsafe!) + +(provide widget% + gtk->wx + + gtk_widget_show + gtk_widget_hide + + gtk_vbox_new + gtk_box_pack_start + gtk_box_pack_end) + +(define-gtk gtk_widget_show (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) + +(define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) +(define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) +(define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) + +(define widget% + (class object% + (init gtk + [extra-gtks null]) + (init-field [eventspace (current-eventspace)]) + + (define/public (get-eventspace) eventspace) + (define/public (direct-update?) #t) + + (super-new) + + (let ([cell (malloc-immobile-cell this)]) + (g_object_set_data gtk "wx" cell) + (for ([gtk (in-list extra-gtks)]) + (g_object_set_data gtk "wx" cell))))) + +(define (gtk->wx gtk) + (let ([ptr (g_object_get_data gtk "wx")]) + (and ptr (ptr-ref ptr _scheme)))) + +(set-widget-hook! (lambda (gtk) + (let loop ([gtk gtk]) + (and gtk + (let ([wx (gtk->wx gtk)]) + (or wx + (loop (gtk_widget_get_parent gtk)))))))) + diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt new file mode 100644 index 00000000..22ccf89e --- /dev/null +++ b/collects/mred/private/wx/gtk/window.rkt @@ -0,0 +1,324 @@ +#lang racket/base +(require ffi/unsafe + racket/class + ffi/unsafe/atomic + "../../syntax.rkt" + "../common/event.rkt" + "../cocoa/freeze.rkt" + "keycode.rkt" + "queue.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "widget.rkt") + +(provide window% + gtk->wx + queue-window-event + + gtk_widget_show + gtk_widget_hide + gtk_widget_realize + gtk_container_add + gtk_widget_add_events + gtk_widget_size_request + gtk_widget_set_size_request + gtk_widget_grab_focus + gtk_widget_set_sensitive + + connect-focus + connect-key-and-mouse + + (struct-out GtkRequisition) _GtkRequisition-pointer + (struct-out GtkAllocation) _GtkAllocation-pointer) + +;; ---------------------------------------- + +(define-gtk gtk_container_add (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_widget_realize (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_add_events (_fun _GtkWidget _int -> _void)) + +(define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32)) + +(define-cstruct _GtkRequisition ([width _int] + [height _int])) +(define-cstruct _GtkAllocation ([x _int] + [y _int] + [width _int] + [height _int])) + +(define _GdkEventFocus-pointer _pointer) + +(define-gtk gtk_widget_size_request (_fun _GtkWidget _GtkRequisition-pointer -> _void)) +(define-gtk gtk_widget_size_allocate (_fun _GtkWidget _GtkAllocation-pointer -> _void)) +(define-gtk gtk_widget_set_size_request (_fun _GtkWidget _int _int -> _void)) +(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) + +;; ---------------------------------------- + +(define-signal-handler connect-focus-in "focus-in-event" + (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (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) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () (send wx on-kill-focus))) + #f))) +(define (connect-focus gtk) + (connect-focus-in gtk) + (connect-focus-out gtk)) + +;; ---------------------------------------- + +(define-signal-handler connect-key-press "key-press-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (let* ([wx (gtk->wx gtk)] + [modifiers (GdkEventKey-state event)] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [k (new key-event% + [key-code (let ([kv (GdkEventKey-keyval event)]) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [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)] + [x 0] + [y 0] + [time-stamp (GdkEventKey-time event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (if (send wx handles-events?) + (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) + (lambda (gtk event) + (do-button-event gtk event #f))) + +(define-signal-handler connect-button-release "button-release-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #f))) + +(define-signal-handler connect-pointer-motion "motion-notify-event" + (_fun _GtkWidget _GdkEventMotion-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #t))) + +(define (connect-key-and-mouse gtk) + (connect-key-press gtk) + (connect-button-press gtk) + (connect-button-release gtk) + (connect-pointer-motion gtk)) + +(define (do-button-event gtk event motion?) + (let ([type (if motion? + GDK_MOTION_NOTIFY + (GdkEventButton-type event))]) + (unless (or (= type GDK_2BUTTON_PRESS) + (= type GDK_3BUTTON_PRESS)) + (let* ([wx (gtk->wx gtk)] + [modifiers (if motion? + (GdkEventMotion-state event) + (GdkEventButton-state event))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [m (new mouse-event% + [event-type (cond + [(= type GDK_MOTION_NOTIFY) + 'motion] + [(= type GDK_BUTTON_PRESS) + (case (GdkEventButton-button event) + [(1) 'left-down] + [(3) 'right-down] + [else 'middle-down])] + [else + (case (GdkEventButton-button event) + [(1) 'left-up] + [(3) 'right-up] + [else 'middle-up])])] + [left-down (bit? modifiers GDK_BUTTON1_MASK)] + [middle-down (bit? modifiers GDK_BUTTON2_MASK)] + [right-down (bit? modifiers GDK_BUTTON2_MASK)] + [x (->long ((if motion? GdkEventMotion-x GdkEventButton-x) event))] + [y (->long ((if motion? GdkEventMotion-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 GdkEventButton-time) event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (if (send wx handles-events?) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))))) + +;; ---------------------------------------- + +(define window% + (class widget% + (init-field parent + gtk) + (init [no-show? #f] + [extra-gtks null] + [add-to-parent? #t]) + + (super-new [gtk gtk] + [extra-gtks extra-gtks]) + + (define save-x 0) + (define save-y 0) + (define save-w 0) + (define save-h 0) + + (when add-to-parent? + (gtk_container_add (send parent get-client-gtk) gtk)) + + (define/public (get-gtk) gtk) + (define/public (get-client-gtk) gtk) + (define/public (get-window-gtk) (send parent get-window-gtk)) + + (define/public (move x y) + (set! save-x x) + (set! save-y y) + (when parent + (send parent set-child-position gtk x y))) + (define/public (set-size x y w h) + (unless (= x -11111) (set! save-x x)) + (unless (= y -11111) (set! save-y y)) + (unless (= w -1) (set! save-w w)) + (unless (= h -1) (set! save-h h)) + (if parent + (send parent set-child-size gtk save-x save-y save-w save-h) + (set-child-size gtk save-x save-y save-w save-h))) + (define/public (set-child-size child-gtk x y w h) + (gtk_widget_set_size_request child-gtk w h) + (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) + + (define/public (set-auto-size) + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (set-size -11111 + -11111 + (GtkRequisition-width req) + (GtkRequisition-height req)))) + + (define shown? #f) + (define/public (direct-show on?) + (if on? + (gtk_widget_show gtk) + (gtk_widget_hide gtk)) + (set! shown? (and on? #t))) + (define/public (show on?) + (direct-show on?)) + (define/public (is-shown?) shown?) + (define/public (is-shown-to-root?) + (and shown? + (if parent + (send parent is-shown-to-root?) + #t))) + + (unless no-show? (show #t)) + + (define/public (get-x) save-x) + (define/public (get-y) save-y) + (define/public (get-width) save-w) + (define/public (get-height) save-h) + + (define/public (get-parent) parent) + + (define/public (get-size xb yb) + (set-box! xb save-w) + (set-box! yb save-h)) + (define/public (get-client-size xb yb) + (get-size xb yb)) + + (define enabled? #t) + (define/pubment (is-enabled-to-root?) + (and enabled? + (inner (send parent is-enabled-to-root?) + is-enabled-to-root?))) + (define/public (enable on?) + (set! enabled? on?) + (gtk_widget_set_sensitive gtk on?)) + (define/public (is-window-enabled?) enabled?) + + (define/public (drag-accept-files on?) (void)) + + (define/public (set-focus) + (gtk_widget_grab_focus gtk)) + + (define/public (set-cursor v) + (void)) + + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + + (define/public (handles-events?) #f) + (define/public (dispatch-on-char e just-pre?) + (cond + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when enabled? (on-char e)) #t])) + (define/public (dispatch-on-event e just-pre?) + (cond + [(call-pre-on-event this e) #t] + [just-pre? #f] + [else (when enabled? (on-event e)) #t])) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (on-char e) (void)) + (define/public (on-event e) (void)) + + (def/public-unimplemented on-drop-file) + (def/public-unimplemented on-size) + (def/public-unimplemented get-handle) + (def/public-unimplemented set-phantom-size) + (def/public-unimplemented popup-menu) + (define/public (center a b) (void)) + (def/public-unimplemented get-text-extent) + (define/public (refresh) (void)) + + (define/public (screen-to-client x y) + (let ([xb (box 0)] + [yb (box 0)]) + (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) + (send parent screen-to-client x y) + (set-box! x (+ (unbox x) save-x)) + (set-box! y (+ (unbox y) save-y))) + + (def/public-unimplemented get-position) + (def/public-unimplemented fit) + + (define/public (gets-focus?) #t) + + (def/public-unimplemented centre))) + +(define (queue-window-event win thunk) + (queue-event (send win get-eventspace) thunk)) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt new file mode 100644 index 00000000..d67ffc6a --- /dev/null +++ b/collects/mred/private/wx/platform.rkt @@ -0,0 +1,87 @@ +#lang scheme/base +(require scheme/runtime-path (for-syntax scheme/base)) +(provide (all-defined-out)) + +(define-runtime-path platform-lib + (case (system-type) + [() '(lib "mred/private/wx/win32/platform.rkt")] + [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] + [(windows unix) '(lib "mred/private/wx/gtk/platform.rkt")])) + +(define-values (button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + gl-context% + group-box% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-group% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + begin-busy-cursor + is-busy? + end-busy-cursor + has-x-selection? + hide-cursor + bell + display-size + display-origin + get-resource + write-resource + flush-display + fill-private-color + cancel-quit + get-control-font-size + key-symbol-to-integer + draw-tab-base + draw-tab + set-combo-box-font + get-double-click-time + run-printout + end-refresh-sequence + begin-refresh-sequence + file-creator-and-type + send-event + set-executer + set-dialogs + location->window + set-menu-tester + in-atomic-region + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + get-top-level-windows + find-graphical-system-path + check-for-break + play-sound + get-panel-background + get-font-from-user + get-color-from-user + application-pref-handler + application-about-handler + application-quit-handler + application-file-handler + special-option-key + special-control-key) + ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt new file mode 100644 index 00000000..d81e35ab --- /dev/null +++ b/collects/mred/private/wx/win32/button.rkt @@ -0,0 +1,10 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide button%) + +(defclass button% item% + (def/public-unimplemented set-border) + (super-new)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt new file mode 100644 index 00000000..141dd440 --- /dev/null +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -0,0 +1,30 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide canvas%) + +(defclass canvas% window% + (def/public-unimplemented get-canvas-background) + (def/public-unimplemented set-canvas-background) + (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented on-scroll) + (def/public-unimplemented set-scroll-page) + (def/public-unimplemented set-scroll-range) + (def/public-unimplemented set-scroll-pos) + (def/public-unimplemented get-scroll-page) + (def/public-unimplemented get-scroll-range) + (def/public-unimplemented get-scroll-pos) + (def/public-unimplemented scroll) + (def/public-unimplemented warp-pointer) + (def/public-unimplemented view-start) + (def/public-unimplemented set-resize-corner) + (def/public-unimplemented show-scrollbars) + (def/public-unimplemented set-scrollbars) + (def/public-unimplemented get-virtual-size) + (def/public-unimplemented get-dc) + (def/public-unimplemented on-char) + (def/public-unimplemented on-event) + (def/public-unimplemented on-paint) + (super-new)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt new file mode 100644 index 00000000..2479deac --- /dev/null +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -0,0 +1,11 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide check-box%) + +(defclass check-box% item% + (def/public-unimplemented set-value) + (def/public-unimplemented get-value) + (super-new)) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt new file mode 100644 index 00000000..935a35b0 --- /dev/null +++ b/collects/mred/private/wx/win32/choice.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide choice%) + +(defclass choice% item% + (def/public-unimplemented set-selection) + (def/public-unimplemented get-selection) + (def/public-unimplemented number) + (def/public-unimplemented clear) + (def/public-unimplemented append) + (super-new)) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt new file mode 100644 index 00000000..76a531e5 --- /dev/null +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -0,0 +1,12 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide clipboard-driver% + has-x-selection?) + +(define (has-x-selection?) #f) + +(defclass clipboard-driver% object% + (init x-selection?) ; always #f + (super-new)) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt new file mode 100644 index 00000000..aeb05216 --- /dev/null +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide cursor-driver%) + +(defclass cursor-driver% object% + (def/public-unimplemented ok?) + (super-new)) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt new file mode 100644 index 00000000..837102e1 --- /dev/null +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide dialog%) + +(defclass dialog% window% + (def/public-unimplemented system-menu) + (def/public-unimplemented set-title) + (def/public-unimplemented enforce-size) + (def/public-unimplemented on-close) + (def/public-unimplemented on-activate) + (super-new)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt new file mode 100644 index 00000000..a9553e40 --- /dev/null +++ b/collects/mred/private/wx/win32/frame.rkt @@ -0,0 +1,30 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide frame%) + +(defclass frame% window% + (def/public-unimplemented on-toolbar-click) + (def/public-unimplemented on-menu-click) + (def/public-unimplemented on-menu-command) + (def/public-unimplemented on-mdi-activate) + (def/public-unimplemented enforce-size) + (def/public-unimplemented on-close) + (def/public-unimplemented on-activate) + (def/public-unimplemented designate-root-frame) + (def/public-unimplemented system-menu) + (def/public-unimplemented set-modified) + (def/public-unimplemented create-status-line) + (def/public-unimplemented is-maximized?) + (def/public-unimplemented maximize) + (def/public-unimplemented status-line-exists?) + (def/public-unimplemented iconized?) + (def/public-unimplemented set-status-text) + (def/public-unimplemented get-menu-bar) + (def/public-unimplemented set-menu-bar) + (def/public-unimplemented set-icon) + (def/public-unimplemented iconize) + (def/public-unimplemented set-title) + (super-new)) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt new file mode 100644 index 00000000..9051cf18 --- /dev/null +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -0,0 +1,13 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide gauge%) + +(defclass gauge% item% + (def/public-unimplemented get-value) + (def/public-unimplemented set-value) + (def/public-unimplemented get-range) + (def/public-unimplemented set-range) + (super-new)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt new file mode 100644 index 00000000..ba5d78e0 --- /dev/null +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -0,0 +1,11 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide gl-context%) + +(defclass gl-context% object% + (def/public-unimplemented call-as-current) + (def/public-unimplemented swap-buffers) + (def/public-unimplemented ok?) + (super-new)) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt new file mode 100644 index 00000000..f50287c2 --- /dev/null +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide group-panel%) + +(defclass group-panel% window% + (super-new)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt new file mode 100644 index 00000000..c76201cd --- /dev/null +++ b/collects/mred/private/wx/win32/item.rkt @@ -0,0 +1,12 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide item%) + +(defclass item% window% + (def/public-unimplemented set-label) + (def/public-unimplemented get-label) + (def/public-unimplemented command) + (super-new)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt new file mode 100644 index 00000000..0ea610c1 --- /dev/null +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -0,0 +1,26 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide list-box%) + +(defclass list-box% item% + (def/public-unimplemented get-label-font) + (def/public-unimplemented set-string) + (def/public-unimplemented set-first-visible-item) + (def/public-unimplemented set) + (def/public-unimplemented get-selections) + (def/public-unimplemented get-first-item) + (def/public-unimplemented number-of-visible-items) + (def/public-unimplemented number) + (def/public-unimplemented get-selection) + (def/public-unimplemented set-data) + (def/public-unimplemented get-data) + (def/public-unimplemented selected?) + (def/public-unimplemented set-selection) + (def/public-unimplemented select) + (def/public-unimplemented delete) + (def/public-unimplemented clear) + (def/public-unimplemented append) + (super-new)) diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt new file mode 100644 index 00000000..f8feb528 --- /dev/null +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -0,0 +1,13 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide menu-bar%) + +(defclass menu-bar% object% + (def/public-unimplemented set-label-top) + (def/public-unimplemented number) + (def/public-unimplemented enable-top) + (def/public-unimplemented delete) + (def/public-unimplemented append) + (super-new)) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt new file mode 100644 index 00000000..3b0f521c --- /dev/null +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide menu-item%) + +(defclass menu-item% object% + (def/public-unimplemented id) + (super-new)) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt new file mode 100644 index 00000000..06e79d85 --- /dev/null +++ b/collects/mred/private/wx/win32/menu.rkt @@ -0,0 +1,22 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide menu%) + +(defclass menu% object% + (def/public-unimplemented select) + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + (def/public-unimplemented set-label) + (def/public-unimplemented set-help-string) + (def/public-unimplemented number) + (def/public-unimplemented enable) + (def/public-unimplemented check) + (def/public-unimplemented checked?) + (def/public-unimplemented append-separator) + (def/public-unimplemented delete-by-position) + (def/public-unimplemented delete) + (def/public-unimplemented append) + (super-new)) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt new file mode 100644 index 00000000..cd1468e6 --- /dev/null +++ b/collects/mred/private/wx/win32/message.rkt @@ -0,0 +1,10 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide message%) + +(defclass message% item% + (def/public-unimplemented get-font) + (super-new)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt new file mode 100644 index 00000000..69f8d7bf --- /dev/null +++ b/collects/mred/private/wx/win32/panel.rkt @@ -0,0 +1,16 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide panel%) + +(defclass panel% window% + (def/public-unimplemented get-label-position) + (def/public-unimplemented set-label-position) + (def/public-unimplemented on-char) + (def/public-unimplemented on-event) + (def/public-unimplemented on-paint) + (def/public-unimplemented set-item-cursor) + (def/public-unimplemented get-item-cursor) + (super-new)) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt new file mode 100644 index 00000000..246271c5 --- /dev/null +++ b/collects/mred/private/wx/win32/platform.rkt @@ -0,0 +1,107 @@ +#lang scheme/base +(require "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "gl-context.rkt" + "group-box.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-group.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide platform-values) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + gl-context% + group-box% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-group% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + begin-busy-cursor + is-busy? + end-busy-cursor + has-x-selection? + hide-cursor + bell + display-size + display-origin + get-resource + write-resource + flush-display + fill-private-color + cancel-quit + get-control-font-size + key-symbol-to-integer + draw-tab-base + draw-tab + set-combo-box-font + get-double-click-time + run-printout + end-refresh-sequence + begin-refresh-sequence + file-creator-and-type + send-event + set-executer + set-dialogs + location->window + set-menu-tester + in-atomic-region + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + get-top-level-windows + find-graphical-system-path + check-for-break + play-sound + get-panel-background + get-font-from-user + get-color-from-user + application-pref-handler + application-about-handler + application-quit-handler + application-file-handler + special-option-key + special-control-key)) diff --git a/collects/mred/private/wx/win32/printer-dc.rkt b/collects/mred/private/wx/win32/printer-dc.rkt new file mode 100644 index 00000000..38819ef7 --- /dev/null +++ b/collects/mred/private/wx/win32/printer-dc.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require racket/class + racket/draw/dc) + +(provide printer-dc%) + +(define dc-backend% + (class default-dc-backend% + (init [parent #f]) + + (super-new))) + +(define printer-dc% + (dc-mixin dc-backend%)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt new file mode 100644 index 00000000..8d790d2f --- /dev/null +++ b/collects/mred/private/wx/win32/procs.rkt @@ -0,0 +1,110 @@ +#lang scheme/base +(require "../../syntax.rkt") + +(provide + special-control-key + special-option-key + application-file-handler + application-quit-handler + application-about-handler + application-pref-handler + get-color-from-user + get-font-from-user + get-panel-background + play-sound + check-for-break + find-graphical-system-path + get-top-level-windows + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + in-atomic-region + set-menu-tester + location->window + set-dialogs + set-executer + send-event + file-creator-and-type + begin-refresh-sequence + end-refresh-sequence + run-printout + get-double-click-time + set-combo-box-font + draw-tab + draw-tab-base + key-symbol-to-integer + get-control-font-size + cancel-quit + fill-private-color + flush-display + write-resource + get-resource + display-origin + display-size + bell + hide-cursor + end-busy-cursor + is-busy? + begin-busy-cursor + get-display-depth + is-color-display? + file-selector + id-to-menu-item + get-the-x-selection + get-the-clipboard + show-print-setup + can-show-print-setup?) + + +(define-unimplemented special-control-key) +(define-unimplemented special-option-key) +(define-unimplemented application-file-handler) +(define-unimplemented application-quit-handler) +(define-unimplemented application-about-handler) +(define-unimplemented application-pref-handler) +(define-unimplemented get-color-from-user) +(define-unimplemented get-font-from-user) +(define-unimplemented get-panel-background) +(define-unimplemented play-sound) +(define-unimplemented check-for-break) +(define-unimplemented find-graphical-system-path) +(define-unimplemented get-top-level-windows) +(define-unimplemented register-collecting-blit) +(define-unimplemented unregister-collecting-blit) +(define-unimplemented shortcut-visible-in-label?) +(define-unimplemented in-atomic-region) +(define-unimplemented set-menu-tester) +(define-unimplemented location->window) +(define-unimplemented set-dialogs) +(define-unimplemented set-executer) +(define-unimplemented send-event) +(define-unimplemented file-creator-and-type) +(define-unimplemented begin-refresh-sequence) +(define-unimplemented end-refresh-sequence) +(define-unimplemented run-printout) +(define-unimplemented get-double-click-time) +(define-unimplemented set-combo-box-font) +(define-unimplemented draw-tab) +(define-unimplemented draw-tab-base) +(define-unimplemented key-symbol-to-integer) +(define-unimplemented get-control-font-size) +(define-unimplemented cancel-quit) +(define-unimplemented fill-private-color) +(define-unimplemented flush-display) +(define-unimplemented write-resource) +(define-unimplemented get-resource) +(define-unimplemented display-origin) +(define-unimplemented display-size) +(define-unimplemented bell) +(define-unimplemented hide-cursor) +(define-unimplemented end-busy-cursor) +(define-unimplemented is-busy?) +(define-unimplemented begin-busy-cursor) +(define-unimplemented get-display-depth) +(define-unimplemented is-color-display?) +(define-unimplemented file-selector) +(define-unimplemented id-to-menu-item) +(define-unimplemented get-the-x-selection) +(define-unimplemented get-the-clipboard) +(define-unimplemented show-print-setup) +(define-unimplemented can-show-print-setup?) \ No newline at end of file diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt new file mode 100644 index 00000000..2170afd4 --- /dev/null +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -0,0 +1,13 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide radio-box%) + +(defclass radio-box% item% + (def/public-unimplemented button-focus) + (def/public-unimplemented set-selection) + (def/public-unimplemented number) + (def/public-unimplemented get-selection) + (super-new)) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt new file mode 100644 index 00000000..f547ed74 --- /dev/null +++ b/collects/mred/private/wx/win32/slider.rkt @@ -0,0 +1,11 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "item.rkt") + +(provide slider%) + +(defclass slider% item% + (def/public-unimplemented set-value) + (def/public-unimplemented get-value) + (super-new)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt new file mode 100644 index 00000000..386d01e4 --- /dev/null +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt" + "window.rkt") + +(provide tab-panel%) + +(defclass tab-panel% window% + (super-new)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt new file mode 100644 index 00000000..8931831e --- /dev/null +++ b/collects/mred/private/wx/win32/window.rkt @@ -0,0 +1,43 @@ +#lang scheme/base +(require scheme/class + "../../syntax.rkt") + +(provide window%) + +(defclass window% object% + (def/public-unimplemented on-drop-file) + (def/public-unimplemented pre-on-event) + (def/public-unimplemented pre-on-char) + (def/public-unimplemented on-size) + (def/public-unimplemented on-set-focus) + (def/public-unimplemented on-kill-focus) + (def/public-unimplemented get-handle) + (def/public-unimplemented is-enabled-to-root?) + (def/public-unimplemented is-shown-to-root?) + (def/public-unimplemented set-phantom-size) + (def/public-unimplemented get-y) + (def/public-unimplemented get-x) + (def/public-unimplemented get-width) + (def/public-unimplemented get-height) + (def/public-unimplemented popup-menu) + (def/public-unimplemented center) + (def/public-unimplemented get-text-extent) + (def/public-unimplemented get-parent) + (def/public-unimplemented refresh) + (def/public-unimplemented screen-to-client) + (def/public-unimplemented client-to-screen) + (def/public-unimplemented drag-accept-files) + (def/public-unimplemented enable) + (def/public-unimplemented get-position) + (def/public-unimplemented get-client-size) + (def/public-unimplemented get-size) + (def/public-unimplemented fit) + (def/public-unimplemented is-shown?) + (def/public-unimplemented show) + (def/public-unimplemented set-cursor) + (def/public-unimplemented move) + (def/public-unimplemented set-size) + (def/public-unimplemented set-focus) + (def/public-unimplemented gets-focus?) + (def/public-unimplemented centre) + (super-new)) diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 84655732..38ec4ebd 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/collects/mred/private/wxcanvas.rkt @@ -61,24 +61,13 @@ (lambda (e) (let ([mred (get-mred)]) (if mred - ;; Delay callback for Windows scrollbar - ;; and Windows/Mac trampoiline - (queue-window-callback - this - (lambda () (send mred on-scroll e))) + (send mred on-scroll e) (as-exit (lambda () (super on-scroll e)))))))] [on-paint (entry-point (lambda () (let ([mred (get-mred)]) (if mred - (if (and (eq? 'windows (system-type)) - (not (eq? (wx:current-eventspace) - (send (get-top-level) get-eventspace)))) - ;; Windows circumvented the event queue; delay - (queue-window-callback - this - (lambda () (clear-and-on-paint mred))) - (as-exit (lambda () (clear-and-on-paint mred)))) + (as-exit (lambda () (clear-and-on-paint mred))) (as-exit (lambda () (clear-margins) (super on-paint)))))))]) (sequence (apply super-init mred proxy args)))) @@ -228,10 +217,5 @@ 0 0 #t #t))) (inherit editor-canvas-on-scroll) (define/override (on-scroll e) - (if (or (eq? 'windows (system-type)) - (eq? 'macosx (system-type))) - (queue-window-callback - this - (lambda () (editor-canvas-on-scroll))) - (editor-canvas-on-scroll))) + (editor-canvas-on-scroll)) (super-new)))) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index fddd00c0..9853ae4d 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -357,18 +357,10 @@ (define/override (on-set-focus) (super on-set-focus) - (if (eq? 'windows (system-type)) - (queue-window-callback - this - (lambda () (on-focus #t))) - (on-focus #t))) + (on-focus #t)) (define/override (on-kill-focus) (super on-kill-focus) - (if (eq? 'windows (system-type)) - (queue-window-callback - this - (lambda () (on-focus #f))) - (on-focus #f))) + (on-focus #f)) (define/public (is-focus-on?) focuson?) @@ -391,6 +383,7 @@ (set! last-x x) (set! last-y y) + #; (when (and (eq? 'windows (system-type)) (not focuson?) (send event button-down?)) diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index a50d9a08..97d3d6d4 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -3,11 +3,6 @@ (define the-clipboard (get-the-clipboard)) (define the-x-selection-clipboard (get-the-x-selection)) -(define the-brush-list (get-the-brush-list)) -(define the-pen-list (get-the-pen-list)) -(define the-font-list (get-the-font-list)) -(define the-color-database (get-the-color-database)) -(define the-font-name-directory (get-the-font-name-directory)) (define (family-symbol? s) (memq s '(default decorative roman script diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index bbdc91f3..74f7b396 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -14,6 +14,8 @@ (provide (protect wx-panel% wx-vertical-panel% + wx-vertical-tab-panel% + wx-vertical-group-panel% wx-horizontal-panel% wx-pane% wx-vertical-pane% @@ -21,7 +23,7 @@ wx-grow-box-pane%)) (define wx:windowless-panel% - (class100 object% (prnt x y w h style) + (class100 object% (prnt x y w h style label) (private-field [pos-x 0] [pos-y 0] [width 1] [height 1] [parent prnt]) @@ -60,7 +62,7 @@ 2)) (define (wx-make-basic-panel% wx:panel% stretch?) - (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style) + (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style label) (inherit get-x get-y get-width get-height min-width min-height set-min-width set-min-height x-margin y-margin @@ -455,7 +457,7 @@ child-infos placements))]) (sequence - (super-init style parent -1 -1 0 0 (cons 'deleted style)) + (super-init style parent -1 -1 0 0 (cons 'deleted style) label) (unless (memq 'deleted style) (send (get-top-level) show-control this #t))))) @@ -728,20 +730,26 @@ (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) (define wx-panel% (wx-make-panel% wx:panel%)) + (define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) + (define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) + (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) + (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) + (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) + (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) (define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) (define wx-grow-box-pane% - (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style) + (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style label) (override [init-min (lambda (x) (if (or (eq? (system-type) 'macos) (eq? (system-type) 'macosx)) 15 0))]) (sequence - (super-init mred proxy parent style)))) + (super-init mred proxy parent style label)))) (define wx-linear-pane% (wx-make-linear-panel% wx-pane%)) (define wx-horizontal-pane% (wx-make-horizontal-panel% wx-linear-pane%)) (define wx-vertical-pane% (wx-make-vertical-panel% wx-linear-pane%))) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 55a0b2f3..c8f8c237 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -136,7 +136,7 @@ (cdr r)) r))))]) (sequence - (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null)) + (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) (unless (memq 'deleted style) (send (area-parent) add-child this))) (private-field @@ -148,7 +148,7 @@ [dy 0] [p (if horiz? this - (let ([p (make-object wx-vertical-pane% #f proxy this null)]) + (let ([p (make-object wx-vertical-pane% #f proxy this null #f)]) (send p skip-subwindow-events? #t) (send (send p area-parent) add-child p) p))]) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index da720d36..6a86a835 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -69,7 +69,8 @@ (define (make-top-container% base% dlg?) (class100 (wx-make-container% (wx-make-window% base% #t)) (parent . args) (inherit get-x get-y get-width get-height set-size - get-client-size is-shown? on-close enforce-size) + get-client-size is-shown? on-close enforce-size + get-eventspace) (private-field ;; have we had any redraw requests while the window has been ;; hidden? @@ -107,13 +108,8 @@ (lambda (b) (set! enabled? (and b #t)) (super enable b))]) - (private-field - [eventspace (if parent - (send parent get-eventspace) - (wx:current-eventspace))]) (public - [get-eventspace (lambda () eventspace)] [is-enabled? (lambda () enabled?)] @@ -400,7 +396,7 @@ [on-size (lambda (bad-width bad-height) (unless (and already-trying? (not (eq? 'unix (system-type)))) - (parameterize ([wx:current-eventspace eventspace]) + (parameterize ([wx:current-eventspace (get-eventspace)]) (wx:queue-callback (lambda () (resized)) #t))))]) (public @@ -494,7 +490,7 @@ #f)] [candidates (map object->position (container->children panel o #t))] - [dests (filter-overlapping candidates)] + [dests (filter-overlapping candidates)] [pos (if o (object->position o) (list 'x 0 0 1 1))] [o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4) (case code @@ -730,7 +726,7 @@ (define wx-dialog% (make-top-level-window-glue% - 7 + 6 (class100 (make-top-container% wx:dialog% #t) args (sequence (apply super-init args)))))) diff --git a/collects/mred/private/wxwindow.rkt b/collects/mred/private/wxwindow.rkt index 8e708a78..2df610d2 100644 --- a/collects/mred/private/wxwindow.rkt +++ b/collects/mred/private/wxwindow.rkt @@ -201,21 +201,6 @@ (set! old-x x) (set! old-y y) (as-exit (lambda () (send mred on-move x y)))))))))))] - [on-set-focus (entry-point - (lambda () - ; Windows circumvents the event queue to call on-focus - ; when you click on the window's icon in the task bar. - (queue-window-callback - this - (lambda () (send (get-proxy) on-focus #t))) - (as-exit (lambda () (super on-set-focus)))))] - [on-kill-focus (entry-point - (lambda () - ; see on-set-focus: - (queue-window-callback - this - (lambda () (send (get-proxy) on-focus #f))) - (as-exit (lambda () (super on-kill-focus)))))] [pre-on-char (lambda (w e) (or (super pre-on-char w e) (if (skip-subwindow-events?) From 9ff3ba5fa11eb902b343b4b066e0a2514787f0be Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 31 May 2010 19:31:40 -0600 Subject: [PATCH 081/462] fixes for Windows original commit: aabc1cf5a7e3362854777f09a7bf59d4d403dddb --- collects/mred/private/wx/gtk/list-box.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 966b361b..cefaccb7 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -1,5 +1,6 @@ #lang scheme/base -(require scheme/foreign +(require ffi/unsafe + ffi/unsafe/define scheme/class "../../syntax.rkt" "../../lock.rkt" @@ -9,7 +10,6 @@ "window.rkt" "const.rkt" "../common/event.rkt") -(unsafe!) (provide list-box%) @@ -38,8 +38,8 @@ (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) (define _GList (_cpointer 'List)) -(define-gdk g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) -(define-gdk g_list_free (_fun _GList -> _void)) +(define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) +(define-glib g_list_free (_fun _GList -> _void)) (define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) (define-gtk gtk_tree_path_free (_fun _pointer -> _void)) (define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) From 48af0d68355a791102cf3c173848d59a4baaf1f4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Jun 2010 16:17:25 -0600 Subject: [PATCH 082/462] drawing repairs original commit: 88606ae251918bb9002506a0423908f03b226596 --- collects/tests/gracket/draw.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 0af3b7f9..4d7f2b35 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -722,9 +722,11 @@ (let ([start x]) ;; First three return icons: (do-one return 'solid black) + (printf "HERE\n") (do-one return 'solid red) + (printf "DONE\n") (do-one return 'opaque red) - ;; Next three, on a bluew background + ;; Next three, on a blue background (let ([end x] [b (send dc get-brush)]) (send dc set-brush (make-object brush% "BLUE" 'solid)) @@ -1088,7 +1090,10 @@ [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) - (error 'x "wrong size reported by get-size: ~a ~a" w h))) + (error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h + (if use-bitmap? + (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) + (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (send dc set-clipping-region #f) From c0dfb70144c5d09c68c930e4f9cc3bd36978d9e0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Jun 2010 03:44:59 -0400 Subject: [PATCH 083/462] fix drawing bugs and improve backward compatibility original commit: dc00e22b85265605db7493b374015104259e1b48 --- collects/tests/gracket/draw.rkt | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 4d7f2b35..e9d9d59d 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -657,11 +657,11 @@ (case mask-ex-mode [(plt plt-mask plt^plt mred^plt) (let* ([plt (get-plt)] - [tmp-bm (make-object bitmap% - (send mred-icon get-width) - (send mred-icon get-height) - #f)] - [tmp-dc (make-object bitmap-dc% tmp-bm)]) + [ww (send mred-icon get-width)] + [hh (send mred-icon get-height)] + [tmp-bm (make-object bitmap% ww hh #f)] + [tmp-dc (make-object bitmap-dc% tmp-bm)] + [mask-bm tmp-bm]) (send tmp-dc draw-bitmap plt (/ (- (send mred-icon get-width) (send plt get-width)) @@ -669,16 +669,33 @@ (/ (- (send mred-icon get-height) (send plt get-height)) 2)) + (when (memq mask-ex-mode '(plt^plt mred^plt)) + ;; Convert to grayscale + (let ([s (make-bytes (* 4 ww hh))]) + (send tmp-bm get-argb-pixels 0 0 ww hh s) + (for* ([i (in-range 0 ww)] + [j (in-range 0 hh)]) + (let* ([p (* 4 (+ (* j ww) i))] + [v (quotient (+ (bytes-ref s (+ p 1)) + (bytes-ref s (+ p 2)) + (bytes-ref s (+ p 3))) + 3)]) + (bytes-set! s (+ p 1) v) + (bytes-set! s (+ p 2) v) + (bytes-set! s (+ p 3) v))) + (set! mask-bm (make-object bitmap% ww hh #f)) + (send tmp-dc set-bitmap mask-bm) + (send tmp-dc set-argb-pixels 0 0 ww hh s))) (if (eq? mask-ex-mode 'mred^plt) (send dc draw-bitmap mred-icon x y 'solid (send the-color-database find-color "BLACK") - tmp-bm) + mask-bm) (send dc draw-bitmap tmp-bm x y 'solid (send the-color-database find-color "BLACK") (cond [(eq? mask-ex-mode 'plt-mask) mred-icon] - [(eq? mask-ex-mode 'plt^plt) tmp-bm] + [(eq? mask-ex-mode 'plt^plt) mask-bm] [else #f]))))] [(mred^mred) (send dc draw-bitmap mred-icon x y @@ -722,9 +739,7 @@ (let ([start x]) ;; First three return icons: (do-one return 'solid black) - (printf "HERE\n") (do-one return 'solid red) - (printf "DONE\n") (do-one return 'opaque red) ;; Next three, on a blue background (let ([end x] From bfef0ad30867d09eca119a6762eddad83301596f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 12 Jun 2010 09:56:01 -0600 Subject: [PATCH 084/462] Windows build and config repairs original commit: 0709870ef92396afe505439eb65daf797e7e71c7 --- collects/mred/private/wx/gtk/init.rkt | 10 ++++++++++ collects/mred/private/wx/gtk/utils.rkt | 5 +---- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/gtk/init.rkt b/collects/mred/private/wx/gtk/init.rkt index 4effb240..190be27f 100644 --- a/collects/mred/private/wx/gtk/init.rkt +++ b/collects/mred/private/wx/gtk/init.rkt @@ -7,6 +7,16 @@ (define-gtk gtk_init (_fun (_ptr io _int) (_ptr io _pointer) -> _void)) +(define-gtk gtk_rc_parse_string (_fun _string -> _void)) +(define-gtk gtk_rc_add_default_file (_fun _path -> _void)) +(define-gtk gtk_rc_find_module_in_path (_fun _path -> _path)) +(define-gtk gtk_rc_get_module_dir (_fun -> _path)) + +(when (eq? 'windows (system-type)) + (let ([dir (simplify-path (build-path (collection-path "scheme") 'up 'up "lib"))]) + (gtk_rc_parse_string (format "module_path \"~a\"\n" dir)) + (gtk_rc_add_default_file (build-path dir "gtkrc")))) + (gtk_init 0 #f) (define pump-thread (gtk-start-event-pump)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index dda5ba82..d3c6946c 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -99,10 +99,7 @@ (define (set-gtk-object-flags! gtk v) (set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)) -(define-gtk gtk_rc_parse (_fun _path -> _void)) -(define-gmodule g_module_open (_fun _path _int -> _pointer)) -(when (eq? 'windows (system-type)) - (gtk_rc_parse (build-path (collection-path "scheme") 'up 'up "lib" "gtkrc"))) +(define-gmodule g_module_open (_fun _path _int -> _pointer)) (define-syntax-rule (define-signal-handler connect-name From 7ea46ac0f3d4d444513c7ceab341b5ee86e8d808 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 12 Jun 2010 10:50:16 -0600 Subject: [PATCH 085/462] fix canvas% refresh for Gtk original commit: 1aab1c78a3b88ed75b7c20161aa1dfa04ca35d76 --- collects/mred/private/wx/gtk/canvas.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 6ad214ca..b32b2dbe 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -20,6 +20,8 @@ (define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) +(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) + (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) @@ -169,6 +171,9 @@ (define/public (on-paint) (void)) + (define/override (refresh) + (gtk_widget_queue_draw client-gtk)) + (define/override (internal-on-client-size w h) (send dc reset-dc-size)) From 85489139bb41e7299affb5ce785a4d4a933d23d3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 12 Jun 2010 17:51:21 -0600 Subject: [PATCH 086/462] fix clipping original commit: 049e4dbdcbfdec980ab9ec36586b06a77049cf1b --- collects/tests/gracket/draw.rkt | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index e9d9d59d..11ad0628 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -191,6 +191,11 @@ (send dc set-bitmap #f) bm)) +(define (show-error . args) + (with-handlers ([exn? (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (apply error args))) + (define DRAW-WIDTH 550) (define DRAW-HEIGHT 375) @@ -1005,7 +1010,7 @@ (send dc set-clipping-region r))] [(rect+poly) (let ([r (mk-poly 'winding)]) (send r union (mk-rect)) - (send dc set-clipping-region r))] + (send dc set-clipping-region r))] [(rect+circle) (let ([r (mk-circle)]) (send r union (mk-rect)) (send dc set-clipping-region r))] @@ -1071,9 +1076,9 @@ (unless clock-clip? (let ([r (send dc get-clipping-region)]) - (if (eq? clip 'none) + (if (eq? clip 'none) (when r - (error 'draw-test "shouldn't have been a clipping region")) + (show-error 'draw-test "shouldn't have been a clipping region")) (let*-values ([(x y w h) (send r get-bounding-box)] [(l) (list x y w h)] [(=~) (lambda (x y) @@ -1097,7 +1102,7 @@ (- (/ (caddr l) xscale) offset) (- (/ (cadddr l) yscale) offset)) l))) - (error 'draw-test "clipping region changed badly: ~a" l)))))) + (show-error 'draw-test "clipping region changed badly: ~a" l)))))) (let-values ([(w h) (send dc get-size)]) (unless (cond @@ -1105,10 +1110,10 @@ [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) - (error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h - (if use-bitmap? - (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) - (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) + (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h + (if use-bitmap? + (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) + (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (send dc set-clipping-region #f) From 8a010572e272c1b0e49a000673f7b7203399bf57 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Jun 2010 09:26:44 -0600 Subject: [PATCH 087/462] implement labels for radio-box%, etc. original commit: edd12a64b8fabcba74441bc446e44c2302b3ecef --- collects/mred/private/gdi.rkt | 24 +- collects/mred/private/mritem.rkt | 1 + collects/mred/private/te.rkt | 19 + collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/radio-box.rkt | 17 +- collects/mred/private/wx/cocoa/window.rkt | 1 - collects/mred/private/wx/gtk/window.rkt | 1 - collects/mred/private/wx/win32/window.rkt | 1 - collects/mred/private/wxitem.rkt | 166 +-------- collects/mred/private/wxlitem.rkt | 370 +++++++++++++++++++ collects/mred/private/wxtextfield.rkt | 2 +- collects/mred/private/wxwindow.rkt | 9 + 12 files changed, 424 insertions(+), 189 deletions(-) create mode 100644 collects/mred/private/te.rkt create mode 100644 collects/mred/private/wxlitem.rkt diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 6c7cdb59..15b66935 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -6,6 +6,7 @@ "lock.ss" "check.ss" "wx.ss" + "te.rkt" "mrtop.ss" "mrcanvas.ss") @@ -179,21 +180,14 @@ (as-exit (lambda () (super-init p))))))))) (define get-window-text-extent - (let ([bm #f][dc #f]) - (case-lambda - [(string font) (get-window-text-extent string font #f)] - [(string font combine?) - (check-string 'get-window-text-extent string) - (check-instance 'get-window-text-extent wx:font% 'font% #f font) - (unless bm - (set! bm (make-object wx:bitmap% 2 2)) - (set! dc (make-object wx:bitmap-dc%)) - (send dc set-bitmap bm)) - (unless (send bm ok?) - (error 'get-window-text-extent "couldn't allocate sizing bitmap")) - (let-values ([(w h d a) (send dc get-text-extent string font combine?)]) - (values (inexact->exact w) (inexact->exact h)))]))) - + (case-lambda + [(string font) + (get-window-text-extent string font #f)] + [(string font combine?) + (check-string 'get-window-text-extent string) + (check-instance 'get-window-text-extent wx:font% 'font% #f font) + (let-values ([(w h d a) (get-window-text-extent* string font combine?)]) + (values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))])) (define ugly? (lambda (a) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 31231d5c..6e8fa470 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -11,6 +11,7 @@ "helper.ss" "wx.ss" "wxitem.ss" + "wxlitem.ss" "mrwindow.ss" "mrcontainer.ss") diff --git a/collects/mred/private/te.rkt b/collects/mred/private/te.rkt new file mode 100644 index 00000000..884c4cc1 --- /dev/null +++ b/collects/mred/private/te.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require racket/class + racket/draw) + +(provide get-window-text-extent*) + +(define get-window-text-extent* + (let ([bm #f][dc #f]) + (case-lambda + [(string font) (get-window-text-extent* string font #f)] + [(string font combine?) + (unless bm + (set! bm (make-object bitmap% 2 2)) + (set! dc (make-object bitmap-dc%)) + (send dc set-bitmap bm)) + (unless (send bm ok?) + (error 'get-window-text-extent "couldn't allocate sizing bitmap")) + (let-values ([(w h d a) (send dc get-text-extent string font combine?)]) + (values w h d a))]))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 881da5eb..097df99f 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -16,7 +16,7 @@ (define (panel-mixin %) (class % - (define lbl-pos 'vertical) + (define lbl-pos 'horizontal) (super-new) (define/public (get-label-position) lbl-pos) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index df2a6940..88db1642 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -65,6 +65,8 @@ font) (inherit get-cocoa set-focus) + (define horiz? (and (memq 'horizontal style) #t)) + (super-new [parent parent] [cocoa (let ([cocoa @@ -76,13 +78,13 @@ cellClass: (if (andmap string? labels) NSButtonCell MyImageButtonCell) - numberOfRows: #:type _NSInteger (length labels) - numberOfColumns: #:type _NSInteger 1))]) + numberOfRows: #:type _NSInteger (if horiz? 1 (length labels)) + numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))]) (for ([label (in-list labels)] [i (in-naturals)]) (let ([button (tell cocoa - cellAtRow: #:type _NSInteger i - column: #:type _NSInteger 0)]) + cellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0))]) (if (and (not (string? label)) (send label ok?)) (begin @@ -112,7 +114,10 @@ (set-focus))) (define/public (set-selection i) - (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger i column: #:type _NSInteger 0)) + (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0))) (define/public (get-selection) - (tell #:type _NSInteger (get-cocoa) selectedRow)) + (if horiz? + (tell #:type _NSInteger (get-cocoa) selectedColumn) + (tell #:type _NSInteger (get-cocoa) selectedRow))) (define/public (number) count)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 72b9b342..807f93e7 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -297,7 +297,6 @@ (def/public-unimplemented set-phantom-size) (def/public-unimplemented popup-menu) (define/public (center a b) (void)) - (def/public-unimplemented get-text-extent) (def/public-unimplemented refresh) (def/public-unimplemented screen-to-client) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 22ccf89e..afe8079b 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -299,7 +299,6 @@ (def/public-unimplemented set-phantom-size) (def/public-unimplemented popup-menu) (define/public (center a b) (void)) - (def/public-unimplemented get-text-extent) (define/public (refresh) (void)) (define/public (screen-to-client x y) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 8931831e..30221b71 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -21,7 +21,6 @@ (def/public-unimplemented get-height) (def/public-unimplemented popup-menu) (def/public-unimplemented center) - (def/public-unimplemented get-text-extent) (def/public-unimplemented get-parent) (def/public-unimplemented refresh) (def/public-unimplemented screen-to-client) diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt index fe6497cb..e3b1dd62 100644 --- a/collects/mred/private/wxitem.rkt +++ b/collects/mred/private/wxitem.rkt @@ -2,7 +2,6 @@ (require mzlib/class mzlib/class100 mzlib/etc - mzlib/file (prefix wx: "kernel.ss") "lock.ss" "helper.ss" @@ -16,12 +15,7 @@ make-simple-control% wx-button% wx-check-box% - wx-choice% - wx-message% - wx-gauge% - wx-list-box% - wx-radio-box% - wx-slider%)) + wx-message%)) ;; make-item%: creates items which are suitable for placing into ;; containers. @@ -246,162 +240,8 @@ (set-value (not (get-value))) (command (make-object wx:control-event% 'check-box)))))]) (sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font)))) - (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) - (override - [handles-key-code - (lambda (x alpha? meta?) - (or (memq x '(up down)) - (and alpha? (not meta?))))]) - (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font)))) + (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font) (override [gets-focus? (lambda () #f)]) - (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font)))) - - (define wx-gauge% - (make-window-glue% - (class100 (make-control% wx:gauge% - const-default-x-margin const-default-y-margin - #f #f) - (parent label range style font) - (inherit get-client-size get-width get-height set-size - stretchable-in-x stretchable-in-y set-min-height set-min-width - get-parent) - (override [gets-focus? (lambda () #f)]) - (private-field - ;; # pixels per unit of value. - [pixels-per-value 1]) - (sequence - (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font) - - (let-values ([(client-width client-height) (get-two-int-values - (lambda (a b) (get-client-size a b)))]) - (let ([delta-w (- (get-width) client-width)] - [delta-h (- (get-height) client-height)] - [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] - [horizontal? (memq 'horizontal style)]) - (set-min-width (if horizontal? - (let ([cw (min const-max-gauge-length - (* range pixels-per-value))]) - (max (if vertical-labels? - cw - (+ cw delta-w)) - (get-width))) - ;; client-height is the default - ;; dimension in the minor direction. - (+ client-width delta-w))) - (set-min-height (if horizontal? - (+ client-height delta-h) - (let ([ch (min const-max-gauge-length - (* range pixels-per-value))]) - (max (if vertical-labels? - (+ ch delta-h) - ch) - (get-height))))))) - - (if (memq 'horizontal style) - (begin - (stretchable-in-x #t) - (stretchable-in-y #f)) - (begin - (stretchable-in-x #f) - (stretchable-in-y #t))))))) - - (define list-box-wheel-step #f) - - (define wx-list-box% - (make-window-glue% - (class100 (make-control% wx:list-box% - const-default-x-margin const-default-y-margin - #t #t) (parent cb label kind x y w h choices style font label-font) - (inherit get-first-item - set-first-visible-item) - (private - [scroll (lambda (dir) - (unless list-box-wheel-step - (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3))) - (unless (and (number? list-box-wheel-step) - (exact? list-box-wheel-step) - (integer? list-box-wheel-step) - (<= 1 list-box-wheel-step 100)) - (set! list-box-wheel-step 3))) - (let ([top (get-first-item)]) - (set-first-visible-item - (max 0 (+ top (* list-box-wheel-step dir))))))]) - (override - [handles-key-code (lambda (x alpha? meta?) - (case x - [(up down) #t] - [else (and alpha? (not meta?))]))] - [pre-on-char (lambda (w e) - (or (super pre-on-char w e) - (case (send e get-key-code) - [(wheel-up) (scroll -1) #t] - [(wheel-down) (scroll 1) #t] - [else #f])))]) - (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) - - (define wx-radio-box% - (make-window-glue% - (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) - (inherit number orig-enable set-selection command) - (override - [enable - (case-lambda - [(on?) (super enable on?)] - [(which on?) (when (< -1 which (number)) - (vector-set! enable-vector which (and on? #t)) - (orig-enable which on?))])] - [is-enabled? - (case-lambda - [() (super is-enabled?)] - [(which) (and (< -1 which (number)) - (vector-ref enable-vector which))])]) - - (private-field [is-vertical? (memq 'vertical style)]) - (public - [vertical? (lambda () is-vertical?)] - [char-to-button (lambda (i) - (as-exit - (lambda () - (set-selection i) - (command (make-object wx:control-event% 'radio-box)))))]) - - (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font)) - - (private-field [enable-vector (make-vector (number) #t)])))) - - (define wx-slider% - (make-window-glue% - (class100 (make-control% wx:slider% - const-default-x-margin const-default-y-margin - #f #f) - (parent func label value min-val max-val style font) - (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y - get-client-size get-width get-height get-parent) - (private-field - ;; # pixels per possible setting. - [pixels-per-value 3]) - ;; 3 is good because with horizontal sliders under Xt, with 1 or 2 - ;; pixels per value, the thumb is too small to display the number, - ;; which looks bad. - - (sequence - (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font) - - (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) - (get-client-size a b)))]) - (let* ([horizontal? (memq 'horizontal style)] - [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] - [range (+ (* pixels-per-value (add1 (- max-val min-val))) - (cond - [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)] - [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)] - [else 0]))]) - ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v))) - (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height)))) - (min const-max-gauge-length range))) - (stretchable-in-x horizontal?) - (stretchable-in-y (not horizontal?)))))))) - - ) + (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt new file mode 100644 index 00000000..54f5b469 --- /dev/null +++ b/collects/mred/private/wxlitem.rkt @@ -0,0 +1,370 @@ +(module wxlitem mzscheme + (require mzlib/class + mzlib/class100 + mzlib/file + (only racket/base remq) + (prefix wx: "kernel.ss") + "lock.ss" + "helper.ss" + "const.ss" + "wx.ss" + "check.ss" + "wxwindow.ss" + "wxitem.ss" + "wxpanel.ss") + + (provide (protect wx-choice% + wx-list-box% + wx-radio-box% + wx-gauge% + wx-slider%)) + + ;; ---------------------------------------- + + (define (is-horiz? style parent) + (cond + [(memq 'vertical-label style) #f] + [(memq 'horizontal-label style) #t] + [else (eq? (send (send parent get-window) get-label-position) 'horizontal)])) + + (define (make-sub horiz? proxy this ha va) + (if horiz? + (begin + (send this alignment ha va) + this) + (let ([p (make-object wx-vertical-pane% #f proxy this null #f)]) + (send p skip-subwindow-events? #t) + (send (send p area-parent) add-child p) + (send p alignment ha va) + p))) + + (define (make-label label proxy p font) + (and label + (let ([l (make-object wx-message% #f proxy p label -1 -1 null font)]) + (send l skip-subwindow-events? #t) + l))) + + (define (filter-style style) + (remq 'deleted style)) + + (define-syntax-rule (bounce c (m arg ...) ...) + (begin + (define/public m (lambda (arg ...) (send c m arg ...))) + ...)) + + ;; ---------------------------------------- + + (define wx-label-panel% + (class wx-horizontal-panel% + (init proxy parent label style font valign) + (inherit area-parent) + (define c #f) + + (define/override (enable on?) (if c (send c enable on?) (void))) + (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t)) + + (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) + (unless (memq 'deleted style) + (send (area-parent) add-child this)) + (define horiz? (is-horiz? style parent)) + (define p (make-sub horiz? proxy this 'left valign)) + + (define l (make-label label proxy p font)) + (define/public (set-label s) (when l (send l set-label s))) + (define/public (get-label) (and l (send l get-label))) + + (define/public (get-p) p) + (define/public (set-c v) + (set! c v) + (send c stretchable-in-x #t) + (send c stretchable-in-y #t) + (send c skip-subwindow-events? #t)))) + + ;; ---------------------------------------- + + (define wx-internal-choice% + (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) + (override + [handles-key-code + (lambda (x alpha? meta?) + (or (memq x '(up down)) + (and alpha? (not meta?))))]) + (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font)))) + + (define wx-choice% + (class wx-label-panel% + (init mred proxy parent cb label x y w h choices style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center) + + (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices + (filter-style style) font)) + (set-c c) + + (bounce + c + (set-selection i) + (get-selection) + (number) + (clear) + (append lbl)) + + (stretchable-in-y #f) + (stretchable-in-x #f))) + + ;; ---------------------------------------- + + (define list-box-wheel-step #f) + + (define wx-internal-list-box% + (make-window-glue% + (class100 (make-control% wx:list-box% + const-default-x-margin const-default-y-margin + #t #t) (parent cb label kind x y w h choices style font label-font) + (inherit get-first-item + set-first-visible-item) + (private + [scroll (lambda (dir) + (unless list-box-wheel-step + (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3))) + (unless (and (number? list-box-wheel-step) + (exact? list-box-wheel-step) + (integer? list-box-wheel-step) + (<= 1 list-box-wheel-step 100)) + (set! list-box-wheel-step 3))) + (let ([top (get-first-item)]) + (set-first-visible-item + (max 0 (+ top (* list-box-wheel-step dir))))))]) + (override + [handles-key-code (lambda (x alpha? meta?) + (case x + [(up down) #t] + [else (and alpha? (not meta?))]))] + [pre-on-char (lambda (w e) + (or (super pre-on-char w e) + (case (send e get-key-code) + [(wheel-up) (scroll -1) #t] + [(wheel-down) (scroll 1) #t] + [else #f])))]) + (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) + + (define wx-list-box% + (class wx-label-panel% + (init mred proxy parent cb label kind x y w h choices style font label-font) + (inherit get-p set-c) + + (super-init proxy parent label style font 'top) + + (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices + (filter-style style) font label-font)) + (set-c c) + + (bounce + c + (get-label-font) + (set-string i s) + (set-selection i) + (get-selection) + (get-selections) + (visible-range) + (get-first-item) + (number-of-visible-items) + (set-first-visible-item i) + (number) + (get-row n) + (set-data i v) + (get-data i) + (selected? i) + (delete i) + (clear i) + (set choices) + (reset)) + (define/public select + (case-lambda + [(i) (send c select i)] + [(i on?) (send c select i on?)] + [(i on? extend?) (send c select i on? extend?)])) + (define/public append + (case-lambda + [(s) (send c append s)] + [(s v) (send c append s v)])))) + + ;; ---------------------------------------- + + (define wx-internal-radio-box% + (make-window-glue% + (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) + (inherit number orig-enable set-selection command) + (override + [enable + (case-lambda + [(on?) (super enable on?)] + [(which on?) (when (< -1 which (number)) + (vector-set! enable-vector which (and on? #t)) + (orig-enable which on?))])] + [is-enabled? + (case-lambda + [() (super is-enabled?)] + [(which) (and (< -1 which (number)) + (vector-ref enable-vector which))])]) + + (private-field [is-vertical? (memq 'vertical style)]) + (public + [vertical? (lambda () is-vertical?)] + [char-to-button (lambda (i) + (as-exit + (lambda () + (set-selection i) + (command (make-object wx:control-event% 'radio-box)))))]) + + (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font)) + + (private-field [enable-vector (make-vector (number) #t)])))) + + (define wx-radio-box% + (class wx-label-panel% + (init mred proxy parent cb label x y w h choices major style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center) + + (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices + major (filter-style style) font)) + (set-c c) + + (bounce + c + (button-focus i) + (set-selection i) + (get-selection)) + (stretchable-in-y #f) + (stretchable-in-x #f))) + + ;; ---------------------------------------- + + (define wx-internal-gauge% + (make-window-glue% + (class100 (make-control% wx:gauge% + const-default-x-margin const-default-y-margin + #f #f) + (parent label range style font) + (inherit get-client-size get-width get-height set-size + stretchable-in-x stretchable-in-y set-min-height set-min-width + get-parent) + (override [gets-focus? (lambda () #f)]) + (private-field + ;; # pixels per unit of value. + [pixels-per-value 1]) + (sequence + (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font) + + (let-values ([(client-width client-height) (get-two-int-values + (lambda (a b) (get-client-size a b)))]) + (let ([delta-w (- (get-width) client-width)] + [delta-h (- (get-height) client-height)] + [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] + [horizontal? (memq 'horizontal style)]) + (set-min-width (if horizontal? + (let ([cw (min const-max-gauge-length + (* range pixels-per-value))]) + (max (if vertical-labels? + cw + (+ cw delta-w)) + (get-width))) + ;; client-height is the default + ;; dimension in the minor direction. + (+ client-width delta-w))) + (set-min-height (if horizontal? + (+ client-height delta-h) + (let ([ch (min const-max-gauge-length + (* range pixels-per-value))]) + (max (if vertical-labels? + (+ ch delta-h) + ch) + (get-height))))))) + + (if (memq 'horizontal style) + (begin + (stretchable-in-x #t) + (stretchable-in-y #f)) + (begin + (stretchable-in-x #f) + (stretchable-in-y #t))))))) + + (define wx-gauge% + (class wx-label-panel% + (init mred proxy parent label range style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center) + + (define c (make-object wx-internal-gauge% mred proxy (get-p) label range + (filter-style style) font)) + (set-c c) + + (bounce + c + (get-range) + (set-range rng) + (get-value) + (set-value v)) + (let ([h? (and (memq 'horizontal style) #t)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?))))) + + ;; ---------------------------------------- + + (define wx-internal-slider% + (make-window-glue% + (class100 (make-control% wx:slider% + const-default-x-margin const-default-y-margin + #f #f) + (parent func label value min-val max-val style font) + (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y + get-client-size get-width get-height get-parent) + (private-field + ;; # pixels per possible setting. + [pixels-per-value 3]) + ;; 3 is good because with horizontal sliders under Xt, with 1 or 2 + ;; pixels per value, the thumb is too small to display the number, + ;; which looks bad. + + (sequence + (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font) + + (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) + (get-client-size a b)))]) + (let* ([horizontal? (memq 'horizontal style)] + [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] + [range (+ (* pixels-per-value (add1 (- max-val min-val))) + (cond + [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)] + [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)] + [else 0]))]) + ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v))) + (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height)))) + (min const-max-gauge-length range))) + (stretchable-in-x horizontal?) + (stretchable-in-y (not horizontal?)))))))) + + (define wx-slider% + (class wx-label-panel% + (init mred proxy parent func label value min-val max-val style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center) + + (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val + (filter-style style) font)) + (set-c c) + + (bounce + c + (get-value) + (set-value v)) + (let ([h? (and (memq 'horizontal style) #t)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?))))) + +) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index c8f8c237..629b070c 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -220,7 +220,7 @@ (set! dy (- dy (unbox ybox)))) ;; Subtract ascent of label - (send l get-text-extent "hi" wbox hbox ybox abox) + (send l get-text-extent "hi" wbox hbox ybox abox font) (set! dy (- dy (- (unbox hbox) (unbox ybox)))) ;; Subtract space above label diff --git a/collects/mred/private/wxwindow.rkt b/collects/mred/private/wxwindow.rkt index 2df610d2..66ab6dff 100644 --- a/collects/mred/private/wxwindow.rkt +++ b/collects/mred/private/wxwindow.rkt @@ -2,6 +2,7 @@ (require mzlib/class mzlib/class100 (prefix wx: "kernel.ss") + "te.rkt" "lock.ss" "helper.ss" "wx.ss") @@ -39,6 +40,14 @@ [() skip-sub-events?] [(skip?) (set! skip-sub-events? skip?)])]) (public + [get-text-extent (lambda (s wb hb db ab font) + (let-values ([(w h d a) (get-window-text-extent* s font #t)]) + (let ([set (lambda (b v) + (when b (set-box! b (inexact->exact (ceiling v)))))]) + (set wb w) + (set hb h) + (set db d) + (set ab a))))] [on-active (lambda () (let ([act? (is-enabled-to-root?)]) From 91452c175af748459f275120a5c9dbb9357b0ec6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Jun 2010 12:32:05 -0600 Subject: [PATCH 088/462] mostly tab-panel and mnemonic repairs original commit: 3cb7594793d690d9898776051741205f9953e6a1 --- collects/mred/private/mrpanel.rkt | 3 +- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/list-box.rkt | 7 +- collects/mred/private/wx/cocoa/radio-box.rkt | 6 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 54 ++++++++++-- collects/mred/private/wx/common/procs.rkt | 8 +- collects/mred/private/wx/gtk/button.rkt | 9 +- collects/mred/private/wx/gtk/check-box.rkt | 4 +- collects/mred/private/wx/gtk/list-box.rkt | 89 ++++++++++++++++---- collects/mred/private/wx/gtk/message.rkt | 29 ++++++- collects/mred/private/wx/gtk/tab-panel.rkt | 79 ++++++++++++++--- collects/mred/private/wxlitem.rkt | 2 +- 12 files changed, 238 insertions(+), 54 deletions(-) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 0fa10e39..34c494af 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -135,7 +135,8 @@ (check-font cwho font)) (super-init parent (if (memq 'deleted style) '(deleted) - null))) + null)) + (send (mred->wx this) set-callback callback)) (public [get-number (lambda () (length save-choices))] diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 3b6fe436..93ec7a9d 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -46,7 +46,7 @@ NSRoundedBezelStyle))) (cond [(string? label) - (tellv cocoa setTitle: #:type _NSString label)] + (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] [(send label ok?) (if button-type (tellv cocoa setTitle: #:type _NSString "") diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index aa3115e3..fa855e30 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -122,9 +122,10 @@ (tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) (define/public (set-string i s) - (append (take items i) - (list s) - (drop items (add1 i))) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) (reset)) (define/public (number) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 88db1642..d2a6df58 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -90,9 +90,9 @@ (begin (tellv button setTitle: #:type _NSString "") (set-ivar! button img (bitmap->image label))) - (tellv button setTitle: #:type _NSString (if (string? label) - label - ""))) + (tellv button setTitleWithMnemonic: #:type _NSString (if (string? label) + label + ""))) (tellv button setButtonType: #:type _int NSRadioButton))) (tellv cocoa sizeToFit) (tellv cocoa setTarget: cocoa) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index fa2f440c..3548c163 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -6,13 +6,22 @@ "types.rkt" "utils.rkt" "window.rkt" - "panel.rkt") + "panel.rkt" + "../common/event.rkt" + "../common/procs.rkt") (unsafe!) (objc-unsafe!) (provide tab-panel%) (import-class NSView NSTabView NSTabViewItem) +(import-protocol NSTabViewDelegate) + +(define-objc-class MyTabView NSTabView + #:protocols (NSTabViewDelegate) + [wx] + (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) + (queue-window-event wx (lambda () (send wx do-callback))))) (defclass tab-panel% (panel-mixin window%) (init parent @@ -22,16 +31,17 @@ (inherit get-cocoa) (define cocoa (as-objc-allocation - (tell (tell NSTabView alloc) init))) + (tell (tell MyTabView alloc) init))) (define item-cocoas (for/list ([lbl (in-list labels)]) (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) - (tellv item setLabel: #:type _NSString lbl) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) (tellv cocoa addTabViewItem: item) item))) (let ([sz (tell #:type _NSSize cocoa minimumSize)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) sz))) + (tellv cocoa setDelegate: cocoa) (define content-cocoa (as-objc-allocation @@ -45,10 +55,44 @@ (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect))) (define/public (set-label i str) - (tellv (list-ref item-cocoas i) setLabel: #:type _NSString str)) - + (tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str))) + (define/public (set-selection i) (tellv cocoa selectTabViewItem: (list-ref item-cocoas i))) + (define/public (get-selection) + (item->index (tell cocoa selectedTabViewItem))) + + (define (item->index tv) + (for/or ([c (in-list item-cocoas)] + [i (in-naturals)]) + (and (ptr-equal? c tv) i))) + + (public [append* append]) + (define (append* lbl) + (let ([item (as-objc-allocation + (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv cocoa addTabViewItem: item) + (set! item-cocoas (append item-cocoas (list item))))) + + (define/public (delete i) + (let ([item-cocoa (list-ref item-cocoas i)]) + (tellv cocoa removeTabViewItem: item-cocoa) + (set! item-cocoas (remq item-cocoa item-cocoas)))) + + (define/public (set choices) + (for ([item-cocoa (in-list item-cocoas)]) + (tellv cocoa removeTabViewItem: item-cocoa)) + (set! item-cocoas null) + (for ([lbl (in-list choices)]) + (append* lbl))) + + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/public (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) (super-new [parent parent] [cocoa cocoa] diff --git a/collects/mred/private/wx/common/procs.rkt b/collects/mred/private/wx/common/procs.rkt index f28ba4a8..362911fc 100644 --- a/collects/mred/private/wx/common/procs.rkt +++ b/collects/mred/private/wx/common/procs.rkt @@ -5,10 +5,10 @@ label->plain-label) (define/top (label->plain-label [string? s]) - (regexp-replace* #rx"&." + (regexp-replace* #rx"&(.)" (regexp-replace - #rx"[(]&.[)] *" + #rx"[(]&(.)[)] *" (regexp-replace #rx"\t.*$" s "") - "") - "")) + "\\1") + "\\1")) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 65c4b0d5..6eeb09ee 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -8,6 +8,7 @@ "window.rkt" "const.rkt" "pixbuf.rkt" + "message.rkt" "../common/event.rkt") (unsafe!) @@ -16,7 +17,7 @@ ;; ---------------------------------------- -(define-gtk gtk_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_button_new (_fun -> _GtkWidget)) (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) @@ -28,7 +29,7 @@ (defclass button-core% item% (init parent cb label x y w h style font - [gtk_new_with_label gtk_button_new_with_label] + [gtk_new_with_mnemonic gtk_button_new_with_mnemonic] [gtk_new gtk_button_new]) (init-field [event-type 'button]) (inherit get-gtk set-auto-size is-window-enabled? @@ -37,7 +38,7 @@ (super-new [parent parent] [gtk (cond [(or (string? label) (not label)) - (gtk_new_with_label (or label ""))] + (gtk_new_with_mnemonic (or (mnemonic-string label) ""))] [(send label ok?) (let ([gtk (gtk_new)] [image-gtk (gtk_image_new_from_pixbuf @@ -46,7 +47,7 @@ (gtk_widget_show image-gtk) gtk)] [else - (gtk_new_with_label "")])] + (gtk_new_with_mnemonic "")])] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt index 495e61ee..d9ff0f56 100644 --- a/collects/mred/private/wx/gtk/check-box.rkt +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -12,13 +12,13 @@ ;; ---------------------------------------- -(define-gtk gtk_check_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_check_button_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_check_button_new (_fun -> _GtkWidget)) (define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) (defclass check-box% button-core% - (super-new [gtk_new_with_label gtk_check_button_new_with_label] + (super-new [gtk_new_with_mnemonic gtk_check_button_new_with_mnemonic] [gtk_new gtk_check_button_new] [event-type 'check-box]) (inherit get-gtk) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index cefaccb7..6d6c3563 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe ffi/unsafe/define scheme/class + (only-in racket/list take drop) "../../syntax.rkt" "../../lock.rkt" "item.rkt" @@ -28,6 +29,7 @@ (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) (define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore)) +(define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void)) (define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) (define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) (define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) @@ -36,11 +38,19 @@ (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) +(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) +(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) (define _GList (_cpointer 'List)) (define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) (define-glib g_list_free (_fun _GList -> _void)) (define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) +(define-gtk gtk_tree_selection_path_is_selected (_fun _GtkWidget _pointer -> _gboolean)) +(define-gtk gtk_tree_selection_unselect_all (_fun _GtkWidget -> _void)) +(define-gtk gtk_tree_selection_select_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_selection_unselect_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_path_new_from_indices (_fun _int _int -> _pointer)) (define-gtk gtk_tree_path_free (_fun _pointer -> _void)) (define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) @@ -65,10 +75,12 @@ (define data (map (lambda (c) (box #f)) choices)) (define store (gtk_list_store_new 1 G_TYPE_STRING)) - (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (for ([s (in-list choices)]) - (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1))) + (define (reset-content) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (for ([s (in-list items)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)))) + (reset-content) (define column (let ([renderer (gtk_cell_renderer_text_new)]) @@ -111,14 +123,37 @@ (queue-window-event this (lambda () - (callback this (new control-event% - [event-type 'list-box] - [time-stamp (current-milliseconds)]))))) + (unless (null? items) + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)])))))) + + (define/private (get-iter i) + (let ([iter (make-GtkTreeIter 0 #f #f #f)] + [p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_model_get_iter store iter p) + (gtk_tree_path_free p) + iter)) (def/public-unimplemented get-label-font) - (def/public-unimplemented set-string) - (def/public-unimplemented set-first-visible-item) - (def/public-unimplemented set) + + (define/public (set-string i s) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) + (gtk_list_store_set store (get-iter i) 0 s -1)) + + (define/public (set-first-visible-item i) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) + (gtk_tree_path_free p))) + + (define/public (set choices) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content)) (define/public (get-selections) (as-entry @@ -163,11 +198,35 @@ (define/public (set-data i v) (set-box! (list-ref data i) v)) (define/public (get-data i) (unbox (list-ref data i))) - (def/public-unimplemented selected?) - (def/public-unimplemented set-selection) - (def/public-unimplemented select) - (def/public-unimplemented delete) - (def/public-unimplemented clear) + (define/public (selected? i) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (begin0 + (gtk_tree_selection_path_is_selected selection p) + (gtk_tree_path_free p)))) + + (define/public (select i [on? #t] [extend? #t]) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p))) + + (define/public (set-selection i) + (select i #t #f)) + + (define/public (delete i) + (set! items (append (take items i) (drop items (add1 i)))) + (set! data (append (take data i) (drop data (add1 i)))) + (gtk_list_store_remove store (get-iter i)) + (void)) + + (define/public (clear) + (set! items null) + (set! data null) + (gtk_list_store_clear store)) (public [append* append]) (define (append* s [v #f]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 011a59b0..0ce0b70d 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -8,12 +8,35 @@ "pixbuf.rkt") (unsafe!) -(provide message%) +(provide message% + + gtk_label_new_with_mnemonic + gtk_label_set_text_with_mnemonic + mnemonic-string) ;; ---------------------------------------- (define-gtk gtk_label_new (_fun _string -> _GtkWidget)) (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) + +(define (mnemonic-string s) + (if (regexp-match? #rx"&" s) + (regexp-replace* + #rx"_&" + (regexp-replace* + #rx"&(.)" + (regexp-replace* #rx"_" s "__") + "_\\1") + "\\&") + (regexp-replace* #rx"_" s "__"))) + +(define (gtk_label_new_with_mnemonic s) + (let ([l (gtk_label_new s)]) + (when (regexp-match? #rx"&" s) + (let ([s (mnemonic-string s)]) + (gtk_label_set_text_with_mnemonic l s))) + l)) (defclass message% item% (init parent label @@ -24,7 +47,7 @@ (super-new [parent parent] [gtk (if (or (string? label) (not label)) - (gtk_label_new (or label "")) + (gtk_label_new_with_mnemonic (or label "")) (if (symbol? label) (gtk_label_new (format "<~a>" label)) (gtk_image_new_from_pixbuf @@ -34,6 +57,6 @@ (set-auto-size) (define/override (set-label s) - (gtk_label_set_text (get-gtk) s)) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index e55ff7cb..1ce9cc41 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -7,7 +7,9 @@ "utils.rkt" "panel.rkt" "types.rkt" - "widget.rkt") + "widget.rkt" + "message.rkt" + "../common/event.rkt") (unsafe!) (provide tab-panel%) @@ -15,10 +17,10 @@ (define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) -(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) -(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) @@ -59,16 +61,19 @@ (define pages (for/list ([lbl labels]) (let ([bin-gtk (gtk_hbox_new #f 0)] - [label-gtk (gtk_label_new lbl)]) + [label-gtk (gtk_label_new_with_mnemonic lbl)]) (gtk_notebook_append_page gtk bin-gtk label-gtk) (gtk_widget_show bin-gtk) (make-page bin-gtk label-gtk)))) + (define/private (install-empty-page) + (gtk_notebook_append_page gtk empty-bin-gtk #f) + (gtk_widget_show empty-bin-gtk)) + (if (null? pages) (begin (select-bin empty-bin-gtk) - (gtk_notebook_append_page gtk empty-bin-gtk #f) - (gtk_widget_show empty-bin-gtk)) + (install-empty-page)) (begin (select-bin (page-bin-gtk (car pages))))) (gtk_widget_show client-gtk) @@ -81,21 +86,71 @@ (set-auto-size) + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/private (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) + + (define/public (swap-in bin-gtk) + (gtk_widget_ref client-gtk) + (gtk_container_remove current-bin-gtk client-gtk) + (select-bin bin-gtk) + (gtk_widget_unref client-gtk)) + (define/public (page-changed i) - (let ([bin-gtk (page-bin-gtk (list-ref pages i))]) - (gtk_widget_ref client-gtk) - (gtk_container_remove current-bin-gtk client-gtk) - (select-bin bin-gtk) - (gtk_widget_unref client-gtk))) + (unless (null? pages) + (swap-in (page-bin-gtk (list-ref pages i))) + (queue-window-event this (lambda () (do-callback))))) (connect-changed gtk) (define/override (get-client-gtk) client-gtk) + (public [append* append]) + (define (append* lbl) + (let ([page + (let ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)]) + (gtk_notebook_append_page gtk bin-gtk label-gtk) + (gtk_widget_show bin-gtk) + (make-page bin-gtk label-gtk))]) + (set! pages (append pages (list page))) + (when (null? (cdr pages)) + (swap-in (page-bin-gtk (car pages))) + (g_object_ref empty-bin-gtk) + (gtk_notebook_remove_page gtk 0)))) + + (define/public (delete i) + (let ([page (list-ref pages i)]) + (when (ptr-equal? current-bin-gtk (page-bin-gtk page)) + (let ([cnt (length pages)]) + (if (= i (sub1 cnt)) + (if (null? (cdr pages)) + (begin + (install-empty-page) + (set! pages null) + (gtk_notebook_set_current_page gtk 1) + (swap-in empty-bin-gtk)) + (gtk_notebook_set_current_page gtk (sub1 i))) + (gtk_notebook_set_current_page gtk (add1 i))))) + (gtk_notebook_remove_page gtk i) + (set! pages (remq page pages)))) + + (define/public (set choices) + (for ([page (in-list pages)]) + (delete 0)) + (for ([lbl (in-list choices)]) + (append* lbl))) + (define/public (set-label i str) - (gtk_label_set_text (page-label-gtk (list-ref pages i)) str)) + (gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i)) + (mnemonic-string str))) (define/public (set-selection i) (gtk_notebook_set_current_page gtk i)) + (define/public (get-selection) + (gtk_notebook_get_current_page gtk)) (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move client-gtk child-gtk x y) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 54f5b469..536ecae7 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -177,7 +177,7 @@ (get-data i) (selected? i) (delete i) - (clear i) + (clear) (set choices) (reset)) (define/public select From 798232e98af2598cc00bd1649558136e4bcad72b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jul 2010 13:42:17 -0600 Subject: [PATCH 089/462] Cocoa menus, including on-demand tricks original commit: 90b005afed683662ed959572609570c5ad185888 --- collects/mred/private/wx/cocoa/frame.rkt | 15 +++-- collects/mred/private/wx/cocoa/freeze.rkt | 3 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 55 ++++++++++++++-- collects/mred/private/wx/cocoa/menu-item.rkt | 55 +++++++++++++++- collects/mred/private/wx/cocoa/menu.rkt | 55 ++++++++++++---- collects/mred/private/wx/cocoa/procs.rkt | 4 +- collects/mred/private/wx/cocoa/queue.rkt | 66 ++++++++++++++++++-- collects/mred/private/wx/common/queue.rkt | 5 +- 8 files changed, 221 insertions(+), 37 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 6d128e71..669ba553 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -57,12 +57,16 @@ (queue-window-event wx (lambda () (send wx on-activate #f))))]) +(set-front-hook! (lambda () (values front + (and front (send front get-eventspace))))) + (set-eventspace-hook! (lambda (w) - (and w - (if (objc-is-a? w MyWindow) - (tell #:type _scheme w getEventspace) - (and front - (send front get-eventspace)))))) + (or (and w + (if (objc-is-a? w MyWindow) + (tell #:type _scheme w getEventspace) + #f)) + (and front + (send front get-eventspace))))) (define (init-pos x y) (if (and (= x -11111) @@ -194,6 +198,7 @@ (define/public (get-menu-bar) mb) (define/public (set-menu-bar _mb) (set! mb _mb) + (send mb set-top-window this) (when (tell #:type _BOOL cocoa isMainWindow) (install-mb))) diff --git a/collects/mred/private/wx/cocoa/freeze.rkt b/collects/mred/private/wx/cocoa/freeze.rkt index b9ad42b4..cfcf2ff4 100644 --- a/collects/mred/private/wx/cocoa/freeze.rkt +++ b/collects/mred/private/wx/cocoa/freeze.rkt @@ -38,7 +38,8 @@ (unless done? (loop))) result) (begin - (fprintf (current-error-port) "WARNING: internal error: wrong eventspace for constrained event handling\n") + (eprintf "WARNING: internal error: wrong eventspace for constrained event handling\n") + (eprintf "~s\n" (continuation-mark-set->context (current-continuation-marks))) default))) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 54360f03..1e18a9de 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -5,13 +5,14 @@ "../../syntax.rkt" "utils.rkt" "types.rkt" - "const.rkt") + "const.rkt" + "queue.rkt") (unsafe!) (objc-unsafe!) (provide menu-bar%) -(import-class NSApplication NSMenu NSMenuItem NSProcessInfo) +(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) (define-cf CFBundleGetMainBundle (_fun -> _pointer)) (define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) @@ -31,7 +32,37 @@ appName)))))) "MrEd")) -(define cocoa-mb (tell (tell NSMenu alloc) init)) +(define-objc-class MyBarMenu NSMenu + [] + ;; Disable automatic handling of keyboard shortcuts + (-a _BOOL (performKeyEquivalent: [_id evt]) + #f)) + +(define cocoa-mb (tell (tell MyBarMenu alloc) init)) +(define current-mb #f) + +;; Used to detect mouse click on the menu bar: +(define in-menu-bar-range + (let ([f (tell #:type _NSRect + (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0) + frame)]) + (let ([x (NSPoint-x (NSRect-origin f))] + [w (NSSize-width (NSRect-size f))] + [y (+ (NSPoint-y (NSRect-origin f)) + (NSSize-height (NSRect-size f)))]) + (lambda (p) + (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) + (and (<= x (NSPoint-x p) (+ x w)) + (<= (- y h) (NSPoint-y p) y))))))) + +(define suspend-menu-bar + (lambda (on?) + ;; We don't actually suspend anything, since the MrEd layer + ;; will drop events that shouldn't be delivered. + (void))) + +(set-menu-bar-hooks! in-menu-bar-range + suspend-menu-bar) ;; Init menu bar (let ([app (tell NSApplication sharedApplication)] @@ -98,7 +129,8 @@ (public [append-menu append]) (define (append-menu menu title) - (set! menus (append menus (list (cons menu title))))) + (set! menus (append menus (list (cons menu title)))) + (send menu set-parent this)) (define/public (install) (let loop () @@ -107,6 +139,19 @@ (loop))) (for-each (lambda (menu) (send (car menu) install cocoa-mb (cdr menu))) - menus)) + menus) + (set! current-mb this)) + + (define top-wx #f) + (define/public (set-top-window top) + (set! top-wx top)) + (define/public (get-top-window) + top-wx) + + (define/public (do-on-menu-click) + (let ([es (send top-wx get-eventspace)]) + (when es + (queue-event es (lambda () + (send top-wx on-menu-click)))))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 932cf207..12999b1a 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -4,7 +4,8 @@ ffi/objc "../../syntax.rkt" "utils.rkt" - "types.rkt") + "types.rkt" + "const.rkt") (unsafe!) (objc-unsafe!) @@ -12,15 +13,63 @@ (import-class NSMenuItem) +(define-objc-class MyMenuItem NSMenuItem + [wx] + (-a _void (selected: [_id sender]) (send wx selected))) + + (defclass menu-item% object% (define/public (id) this) + + (define parent #f) + (define/public (selected) + ;; called in Cocoa thread + (send parent item-selected this)) - (define/public (install menu label) - (let ([item (tell (tell NSMenuItem alloc) + (define/public (set-parent p) + (set! parent p)) + + (define label #f) + (define/public (set-label l) (set! label l)) + (define/public (get-label) label) + + (define checked? #f) + (define/public (set-checked c?) (set! checked? c?)) + (define/public (get-checked) checked?) + + (define enabled? #t) + (define/public (set-enabled-flag e?) (set! enabled? e?)) + (define/public (get-enabled-flag) enabled?) + + (define/public (install menu) + (let ([item (tell (tell MyMenuItem alloc) initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") action: #:type _SEL #f keyEquivalent: #:type _NSString "")]) + (set-ivar! item wx this) (tellv menu addItem: item) + (tellv item setEnabled: #:type _BOOL enabled?) + (tellv item setTarget: item) + (tellv item setAction: #:type _SEL (selector selected:)) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (when shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) (tellv item release))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 394e3763..cbc1e1bd 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -1,10 +1,12 @@ #lang scheme/base (require scheme/class scheme/foreign + (only-in scheme/list drop take) ffi/objc "../../syntax.rkt" "utils.rkt" - "types.rkt") + "types.rkt" + "window.rkt") (unsafe!) (objc-unsafe!) @@ -12,10 +14,7 @@ (import-class NSMenu NSMenuItem) -(define-struct mitem (item - [label #:mutable] - [checked? #:mutable] - [enabled? #:mutable])) +(define-struct mitem (item)) (defclass menu% object% (init-field label @@ -41,19 +40,39 @@ (as-objc-allocation (tell (tell NSMenu alloc) initWithTitle: #:type _NSString label))) + (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) (if item - (send (mitem-item item) install cocoa-menu (mitem-label item)) + (send (mitem-item item) install cocoa-menu) (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) items)) (tellv cocoa-parent addItem: cocoa)) + (define/public (item-selected menu-item) + ;; called in Cocoa thread + (let ([top (get-top-parent)]) + (when top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))))) + + (define parent #f) + (define/public (set-parent p) (set! parent p)) + (define/public (get-top-parent) + ;; called in Cocoa thread + (and parent + (if (parent . is-a? . menu%) + (send parent get-top-parent) + (send parent get-top-window)))) + (public [append-item append]) (define (append-item i label help-str chckable?) - (set! items (append items (list (make-mitem i label #f #f)))) + (send i set-label label) + (set! items (append items (list (make-mitem i)))) + (send i set-parent this) (when cocoa-menu - (send i install cocoa-menu label))) + (send i install cocoa-menu))) (define/public (append-separator) (set! items (append items (list #f))) @@ -87,22 +106,32 @@ (lambda (item-cocoa) (tellv item-cocoa setTitle: #:type _NSString label)) (lambda (mitem) - (set-mitem-label! mitem label)))) + (send (mitem-item mitem) set-label label)))) (define/public (check item on?) (adjust item (lambda (item-cocoa) (tellv item-cocoa setState: #:type _int (if on? 1 0))) (lambda (mitem) - (set-mitem-checked?! mitem (and on? #t))))) + (send (mitem-item mitem) set-checked (and on? #t))))) (define/public (enable item on?) (adjust item (lambda (item-cocoa) (tellv item-cocoa setEnabled: #:type _BOOL on?)) (lambda (mitem) - (set-mitem-enabled?! mitem (and on? #t))))) + (send (mitem-item mitem) set-enabled-flag (and on? #t))))) - (def/public-unimplemented checked?) + (define/public (checked? item) + (send item get-checked)) + (def/public-unimplemented delete-by-position) - (def/public-unimplemented delete)) + + (define/public (delete item) + (let ([pos (find-pos item)]) + (when pos + (let ([mitem (list-ref items pos)]) + (set! items (append (take items pos) + (drop items (add1 pos)))) + (when cocoa-menu + (tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos))))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 3567a33b..b58496d6 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -111,7 +111,7 @@ (set-box! xb (->long (NSSize-width (NSRect-size f)))) (set-box! yb (->long (NSSize-height (NSRect-size f)))))) -(define-unimplemented bell) +(define (bell) (void)) (define (hide-cursor) (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) @@ -123,7 +123,7 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define-unimplemented file-selector) -(define-unimplemented id-to-menu-item) +(define (id-to-menu-item id) id) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index b2ecb480..76e3cb47 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/objc scheme/foreign + scheme/class "pool.rkt" "utils.rkt" "const.rkt" @@ -16,6 +17,8 @@ cocoa-install-event-wakeup queue-event set-eventspace-hook! + set-front-hook! + set-menu-bar-hooks! ;; from common/queue: current-eventspace @@ -31,13 +34,24 @@ [] [-a _BOOL (applicationShouldTerminate: [_id app]) (queue-quit-event) - #t]) + #f]) (tellv app finishLaunching) -(tellv app setDelegate: (tell (tell MyApplicationDelegate alloc) init)) +(define app-delegate (tell (tell MyApplicationDelegate alloc) init)) +(tellv app setDelegate: app-delegate) (tellv app activateIgnoringOtherApps: #:type _BOOL #t) +#| +(import-class NSNotificationCenter) +(define-cocoa NSMenuDidBeginTrackingNotification _id) +(tellv (tell NSNotificationCenter defaultCenter) + addObserver: app-delegate + selector: #:type _SEL (selector trackingMenuNow:) + name: NSMenuDidBeginTrackingNotification + object: #f) +|# + ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up @@ -143,15 +157,55 @@ (define eventspace-hook (lambda (e) #f)) (define (set-eventspace-hook! proc) (set! eventspace-hook proc)) +(define front-hook (lambda () (values #f #f))) +(define (set-front-hook! proc) (set! front-hook proc)) + +(define in-menu-bar-range? (lambda (p) #f)) +(define suspend-menu-bar (lambda (suspend?) (void))) +(define (set-menu-bar-hooks! r? s) + (set! in-menu-bar-range? r?) + (set! suspend-menu-bar s)) + +(define events-suspended? #f) + +(define (check-menu-bar-click evt) + (when (and evt + (= 14 (tell #:type _NSUInteger evt type)) + (= 7 (tell #:type _short evt subtype)) + (not (tell evt window)) + (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) + ;; Mouse down in the menu bar: + (let-values ([(f e) (front-hook)]) + (when e + ;; Don't handle further events until we've made an effort + ;; at on-demand notifications. + (set! events-suspended? #t) + (let ([t (thread (lambda () + (sleep 2) + ;; on-demand took too long, so disable the menu bar + ;; until the application can catch up + (suspend-menu-bar #t) + (set! events-suspended? #f)))]) + (queue-event e (lambda () + (send f on-menu-click) + (set! events-suspended? #f) + (kill-thread t)))))))) + ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) + (when (and events-suspended? wait?) + (suspend-menu-bar #t) + (set! events-suspended? #f)) (begin0 - (let ([evt (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask - untilDate: (if wait? distantFuture #f) - inMode: NSDefaultRunLoopMode - dequeue: #:type _BOOL dequeue?)]) + (let ([evt (if events-suspended? + #f + (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask + untilDate: (if wait? distantFuture #f) + inMode: NSDefaultRunLoopMode + dequeue: #:type _BOOL dequeue?))]) + (when evt (check-menu-bar-click evt)) (and evt (or (not dequeue?) (let ([e (eventspace-hook (tell evt window))]) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 80c4414f..e37778f5 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -3,7 +3,8 @@ racket/draw/utils ffi/unsafe/atomic "rbtree.rkt" - "../../lock.rkt") + "../../lock.rkt" + "handlers.rkt") (provide queue-evt set-check-queue! @@ -317,4 +318,4 @@ 'frame-remove))) (define (queue-quit-event) - (printf "quit!\n")) + (queue-event main-eventspace (application-quit-handler) 'med)) From 85d396413d588142cce9e71d0906a03b7ef0f95d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jul 2010 20:02:51 -0600 Subject: [PATCH 090/462] extend C API to abort/capture cont skipping dynamic-winds original commit: cb69ea3c664a60a56aca46165939826af4b5f29c --- collects/mred/private/wx/{cocoa => common}/freeze.rkt | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/mred/private/wx/{cocoa => common}/freeze.rkt (100%) diff --git a/collects/mred/private/wx/cocoa/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt similarity index 100% rename from collects/mred/private/wx/cocoa/freeze.rkt rename to collects/mred/private/wx/common/freeze.rkt From 8a1032af6c912764f9d22d9d2961d30b1e2437e8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jul 2010 20:03:23 -0600 Subject: [PATCH 091/462] fix constrained-reply to use delim continuations original commit: 88f75dbc133313c715eb290c1ff4abeb3d42aff5 --- collects/mred/private/wx/cocoa/canvas.rkt | 12 +-- collects/mred/private/wx/cocoa/queue.rkt | 11 ++- collects/mred/private/wx/cocoa/slider.rkt | 11 +-- collects/mred/private/wx/cocoa/utils.rkt | 19 +---- collects/mred/private/wx/cocoa/window.rkt | 2 +- collects/mred/private/wx/common/freeze.rkt | 95 ++++++++++++++-------- collects/mred/private/wx/common/utils.rkt | 9 +- collects/mred/private/wx/gtk/menu-bar.rkt | 2 +- collects/mred/private/wx/gtk/queue.rkt | 11 ++- collects/mred/private/wx/gtk/window.rkt | 2 +- 10 files changed, 96 insertions(+), 78 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 2fb3d1c3..57308051 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -14,7 +14,7 @@ "../common/queue.rkt" "../../syntax.rkt" "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt") (provide canvas%) @@ -61,6 +61,7 @@ [gl-config #f]) (inherit get-cocoa + get-eventspace make-graphics-context get-client-size is-shown-to-root? @@ -327,11 +328,12 @@ [event-type kind] [direction direction] [position (get-scroll-pos direction)]))))))) - (frozen-stack-run-some - (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) - 200)) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void))) (define/public (on-scroll e) (void)) - + (define/override (wants-all-events?) ;; Called in Cocoa event-handling mode #t) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 76e3cb47..a4d5f99d 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -8,7 +8,7 @@ "types.rkt" "../common/queue.rkt" "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt") (unsafe!) (objc-unsafe!) @@ -213,11 +213,10 @@ (begin (retain evt) (queue-event e (lambda () - (as-entry (lambda () - (call-with-frozen-stack - (lambda () - (tellv app sendEvent: evt) - (release evt)))))))) + (call-as-unfreeze-point + (lambda () + (tellv app sendEvent: evt) + (release evt)))))) (tellv app sendEvent: evt))) #t))) (tellv pool release)))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index c287e067..d9c06a31 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -10,8 +10,8 @@ "window.rkt" "../common/event.rkt" "../common/queue.rkt" - "../../lock.rkt" - "freeze.rkt") + "../common/freeze.rkt" + "../../lock.rkt") (unsafe!) (objc-unsafe!) @@ -26,9 +26,10 @@ [wx] (-a _void (changed: [_id sender]) (queue-window-event wx (lambda () (send wx changed))) - (frozen-stack-run-some - (lambda () (as-exit (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))))) - 200))) + (constrained-reply + (send wx get-eventspace) + (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))) (defclass slider% item% (init parent cb diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index a4e9d377..aacb4303 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe/objc ffi/unsafe ffi/unsafe/alloc + ffi/unsafe/define "../common/utils.rkt") (provide cocoa-lib @@ -18,21 +19,9 @@ (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) (define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) -(define-syntax define-cocoa/private - (syntax-rules () - [(_ id type) - (define-cocoa/private id id type)] - [(_ id c-id type) - (define id (get-ffi-obj 'c-id cocoa-lib type))])) - -(define-syntax-rule (define-cocoa id type) - (define-cocoa/private id id type)) - -(define-syntax-rule (define-cf id type) - (define id (get-ffi-obj 'id cf-lib type))) - -(define-syntax-rule (define-appserv id type) - (define id (get-ffi-obj 'id appserv-lib type))) +(define-ffi-definer define-cocoa cocoa-lib) +(define-ffi-definer define-cf cf-lib) +(define-ffi-definer define-appserv appserv-lib) (define (objc-delete v) (tellv v release)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 807f93e7..e11beb05 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -9,7 +9,7 @@ "keycode.rkt" "../common/event.rkt" "../../syntax.rkt" - "freeze.rkt") + "../common/freeze.rkt") (unsafe!) (objc-unsafe!) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index cfcf2ff4..e8278e10 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -1,45 +1,74 @@ #lang scheme/base (require scheme/foreign - "../common/utils.rkt" - "../common/queue.rkt") + racket/draw/hold + "utils.rkt" + "queue.rkt" + "../../lock.rkt") (unsafe!) -(provide call-with-frozen-stack - frozen-stack-run-some +(provide call-as-unfreeze-point constrained-reply) -(define-mz scheme_with_stack_freeze (_fun (_fun _scheme -> _int) _scheme -> _int)) -(define-mz scheme_frozen_run_some (_fun (_fun _scheme -> _int) _scheme _int -> _int)) -(define-mz scheme_is_in_frozen_stack (_fun -> _int)) +(define-mz scheme_abort_continuation_no_dws (_fun _scheme _scheme -> _scheme)) +(define-mz scheme_call_with_composable_no_dws (_fun _scheme _scheme -> _scheme)) +(define-mz scheme_set_on_atomic_timeout (_fun (_fun -> _void) -> _pointer)) +(define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer) + #:c-id scheme_set_on_atomic_timeout) -(define (do-apply p) - ;; Continuation prompt ensures that errors do not escape - ;; (and escapes are not supported by the frozen-stack implementation) - (call-with-continuation-prompt p) - 1) +(define freezer-box (make-parameter #f)) +(define freeze-tag (make-continuation-prompt-tag)) -(define (call-with-frozen-stack thunk) - (void (scheme_with_stack_freeze do-apply thunk))) +;; Runs `thunk' atomically, but cooperates with +;; `constrained-reply' to continue a frozen +;; computation in non-atomic mode. +(define (call-as-unfreeze-point thunk) + (let ([b (box #f)]) + (parameterize ([freezer-box b]) + ;; In atomic mode: + (as-entry (lambda () (thunk))) + ;; Out of atomic mode: + (let ([k (unbox b)]) + (when k + (call-with-continuation-prompt + k + freeze-tag))) + (void)))) -(define (frozen-stack-run-some thunk msecs) - (positive? (scheme_frozen_run_some do-apply thunk msecs))) - -;; FIXME: this loop needs to give up on the thunk -;; if it takes too long to return; as long as we're in the -;; loop, no other threads/eventspaces can run -(define (constrained-reply es thunk default) +;; FIXME: waiting 200msec is not a good enough rule. +(define (constrained-reply es thunk default [should-give-up? + (let ([now (current-inexact-milliseconds)]) + (lambda () + ((current-inexact-milliseconds) . > . 200)))]) + (unless (freezer-box) + (log-error "internal error: constrained-reply not within an unfreeze point")) (if (eq? (current-thread) (eventspace-handler-thread es)) - (let ([done? #f] - [result default]) - (frozen-stack-run-some (lambda () (set! result (thunk))) - 200) - (let loop () - (frozen-stack-run-some (lambda () (set! done? #t)) 200) - (unless done? (loop))) - result) + (let* ([prev #f] + [ready? #f] + [handler (lambda () + (when (and ready? (should-give-up?)) + (scheme_call_with_composable_no_dws + (lambda (proc) + (set-box! (freezer-box) proc) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))] + [old (scheme_set_on_atomic_timeout handler)]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev old) + (set! ready? #t) + (begin0 + (parameterize ([freezer-box #f]) + (thunk)) + (scheme_restore_on_atomic_timeout prev))) + freeze-tag))))) (begin - (eprintf "WARNING: internal error: wrong eventspace for constrained event handling\n") - (eprintf "~s\n" (continuation-mark-set->context (current-continuation-marks))) + (log-error "internal error: wrong eventspace for constrained event handling\n") default))) - - diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 8de704c5..5e7e4f02 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -1,8 +1,7 @@ -#lang scheme/base -(require scheme/foreign) -(unsafe!) +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define) (provide define-mz) -(define-syntax-rule (define-mz id type) - (define id (get-ffi-obj 'id #f type))) +(define-ffi-definer define-mz #f) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index dc59e963..84abe61c 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -2,7 +2,7 @@ (require scheme/class scheme/foreign "../../syntax.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "widget.rkt" "utils.rkt" "types.rkt") diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index a37830bf..443f8739 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -5,7 +5,7 @@ "types.rkt" racket/draw/lock "../common/queue.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "const.rkt") (provide gtk-start-event-pump @@ -105,11 +105,10 @@ => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () - (as-entry (lambda () - (call-with-frozen-stack - (lambda () - (gtk_main_do_event evt) - (gdk_event_free evt)))))))))] + (call-as-unfreeze-point + (lambda () + (gtk_main_do_event evt) + (gdk_event_free evt)))))))] [else (gtk_main_do_event evt)]))) (define (uninstall ignored) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index afe8079b..f8d33dbb 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -4,7 +4,7 @@ ffi/unsafe/atomic "../../syntax.rkt" "../common/event.rkt" - "../cocoa/freeze.rkt" + "../common/freeze.rkt" "keycode.rkt" "queue.rkt" "utils.rkt" From 652a1330700c3c6393a65cca7e9518ad06d50f36 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Jul 2010 08:34:35 -0600 Subject: [PATCH 092/462] misc repairs original commit: 4bfed6d7976d8ba10bc00a00aa7155b401b6ea4f --- collects/mred/private/kernel.rkt | 3 +- collects/mred/private/wx/cocoa/button.rkt | 7 +++++ collects/mred/private/wx/cocoa/frame.rkt | 3 +- collects/mred/private/wx/cocoa/image.rkt | 7 ++--- collects/mred/private/wx/cocoa/menu.rkt | 13 ++++---- collects/mred/private/wx/cocoa/platform.rkt | 1 - collects/mred/private/wx/cocoa/procs.rkt | 2 -- collects/mred/private/wx/common/freeze.rkt | 10 +++--- collects/mred/private/wx/common/queue.rkt | 12 ++++++-- collects/mred/private/wx/gtk/button.rkt | 15 +++++++++ collects/mred/private/wx/gtk/pixbuf.rkt | 34 +++++++++++---------- collects/mred/private/wx/gtk/platform.rkt | 1 - collects/mred/private/wx/gtk/procs.rkt | 2 -- collects/mred/private/wx/gtk/radio-box.rkt | 6 +++- collects/mred/private/wx/platform.rkt | 1 - collects/mred/private/wx/win32/platform.rkt | 1 - collects/mred/private/wx/win32/procs.rkt | 2 -- collects/mrlib/bitmap-label.rkt | 1 + 18 files changed, 75 insertions(+), 46 deletions(-) diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 225f28e5..419c6408 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -33,4 +33,5 @@ main-eventspace? eventspace-handler-thread queue-callback - middle-queue-key) + middle-queue-key + get-top-level-windows) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 93ec7a9d..8410b59d 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -103,6 +103,13 @@ (tellv button-cocoa setAction: #:type _SEL (selector clicked:)) (define/override (get-cocoa-control) button-cocoa) + + (define/override (set-label label) + (cond + [(string? label) + (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv cocoa setImage: (bitmap->image label))])) (define callback cb) (define/public (clicked) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 669ba553..4dc7edf4 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -217,8 +217,9 @@ (define/override (call-pre-on-char w e) (pre-on-char w e)) + (define/public (on-menu-click) (void)) + (def/public-unimplemented on-toolbar-click) - (def/public-unimplemented on-menu-click) (def/public-unimplemented on-menu-command) (def/public-unimplemented on-mdi-activate) (def/public-unimplemented on-close) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index d43e1951..808b9b42 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -57,12 +57,11 @@ [h (send bm get-height)] [str (make-bytes (* w h 4) 255)]) (send bm get-argb-pixels 0 0 w h str #f) - (let ([mask-bm (send bm get-loaded-mask)]) - (when mask-bm - (send mask-bm get-argb-pixels 0 0 w h str #t))) + (when (send bm get-loaded-mask) + (send bm get-argb-pixels 0 0 w h str #t)) (as-entry (lambda () - (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4)) (* w h 4) 1)]) + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) (memcpy rgba str (sub1 (* w h 4))) (let* ([cs (CGColorSpaceCreateDeviceRGB)] [provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)] diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index cbc1e1bd..7bf877ca 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -125,13 +125,14 @@ (define/public (checked? item) (send item get-checked)) - (def/public-unimplemented delete-by-position) + (define/public (delete-by-position pos) + (let ([mitem (list-ref items pos)]) + (set! items (append (take items pos) + (drop items (add1 pos)))) + (when cocoa-menu + (tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos)))) (define/public (delete item) (let ([pos (find-pos item)]) (when pos - (let ([mitem (list-ref items pos)]) - (set! items (append (take items pos) - (drop items (add1 pos)))) - (when cocoa-menu - (tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos))))))) + (delete-by-position pos))))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 5e94474f..77bc402c 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -93,7 +93,6 @@ shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit - get-top-level-windows find-graphical-system-path check-for-break play-sound diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index b58496d6..1317a4c1 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -21,7 +21,6 @@ play-sound check-for-break find-graphical-system-path - get-top-level-windows register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? @@ -73,7 +72,6 @@ (define-unimplemented play-sound) (define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented get-top-level-windows) (define (register-collecting-blit . args) (void)) (define (unregister-collecting-blit . args) (void)) (define (shortcut-visible-in-label? [x #f]) #f) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index e8278e10..0183381f 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -29,16 +29,18 @@ ;; Out of atomic mode: (let ([k (unbox b)]) (when k - (call-with-continuation-prompt - k - freeze-tag))) + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt + k + freeze-tag))))) (void)))) ;; FIXME: waiting 200msec is not a good enough rule. (define (constrained-reply es thunk default [should-give-up? (let ([now (current-inexact-milliseconds)]) (lambda () - ((current-inexact-milliseconds) . > . 200)))]) + ((current-inexact-milliseconds) . > . (+ now 200))))]) (unless (freezer-box) (log-error "internal error: constrained-reply not within an unfreeze point")) (if (eq? (current-thread) (eventspace-handler-thread es)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e37778f5..84f20776 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -34,6 +34,7 @@ remove-timer-callback register-frame-shown + get-top-level-windows queue-quit-event) @@ -101,7 +102,7 @@ ;; ------------------------------------------------------------ ;; Eventspaces -(define-struct eventspace (handler-thread queue-proc done-evt) +(define-struct eventspace (handler-thread queue-proc frames-hash done-evt) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -126,7 +127,8 @@ [else 1])))) (define (make-eventspace* th) - (let ([done-sema (make-semaphore 1)]) + (let ([done-sema (make-semaphore 1)] + [frames (make-hasheq)]) (make-eventspace th (let ([count 0]) (let ([lo (mcons #f #f)] @@ -134,7 +136,6 @@ [hi (mcons #f #f)] [timer (box '())] [timer-counter 0] - [frames (make-hasheq)] [newly-posted-sema (make-semaphore)]) (let* ([check-done (lambda () @@ -234,6 +235,7 @@ never-evt))]) (end-atomic) e))])))) + frames (semaphore-peek-evt done-sema)))) (define main-eventspace (make-eventspace* (current-thread))) @@ -317,5 +319,9 @@ 'frame-add 'frame-remove))) +(define (get-top-level-windows) + (hash-map (eventspace-frames-hash (current-eventspace)) + (lambda (k v) k))) + (define (queue-quit-event) (queue-event main-eventspace (application-quit-handler) 'med)) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 6eeb09ee..dbcb1e03 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -20,6 +20,10 @@ (define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_button_new (_fun -> _GtkWidget)) (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void)) + +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) (define-signal-handler connect-clicked "clicked" (_fun _GtkWidget -> _void) @@ -71,6 +75,17 @@ ;; Called from event-handling thread (queue-window-event this (lambda () (clicked)))) + (define/override (set-label s) + (cond + [(string? s) + (gtk_button_set_label gtk (mnemonic-string s))] + [else + (let ([image-gtk (gtk_image_new_from_pixbuf + (bitmap->pixbuf s))]) + (gtk_container_remove gtk (gtk_bin_get_child gtk)) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk))])) + (define/public (set-border on?) (gtk_window_set_default (get-window-gtk) (if on? gtk #f)))) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index 42cca9e2..d94c74d5 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -2,6 +2,7 @@ (require racket/class ffi/unsafe racket/draw + "../../lock.rkt" "../common/bstr.rkt" "utils.rkt" "types.rkt" @@ -35,19 +36,20 @@ [h (send bm get-height)] [str (make-bytes (* w h 4) 255)]) (send bm get-argb-pixels 0 0 w h str #f) - (let ([mask-bm (send bm get-loaded-mask)]) - (when mask-bm - (send mask-bm get-argb-pixels 0 0 w h str #t))) - (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 1)]) - (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) - (for ([i (in-range 0 (* w h 4) 4)]) - (bytes-set! rgba (+ i 3) (bytes-ref str i))) - (gdk_pixbuf_new_from_data rgba - 0 - #t - 8 - w - h - (* w 4) - free-it - #f)))) + (when (send bm get-loaded-mask) + (send bm get-argb-pixels 0 0 w h str #t)) + (as-entry + (lambda () + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) + (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) + (for ([i (in-range 0 (* w h 4) 4)]) + (bytes-set! rgba (+ i 3) (bytes-ref str i))) + (gdk_pixbuf_new_from_data rgba + 0 + #t + 8 + w + h + (* w 4) + free-it + #f)))))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index bec2c5ee..e5305e47 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -93,7 +93,6 @@ shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit - get-top-level-windows find-graphical-system-path check-for-break play-sound diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 99b26a6f..7183f9ad 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -21,7 +21,6 @@ play-sound check-for-break find-graphical-system-path - get-top-level-windows register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? @@ -71,7 +70,6 @@ (define-unimplemented play-sound) (define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) -(define (get-top-level-windows) null) (define (register-collecting-blit . args) (void)) (define (unregister-collecting-blit . args) (void)) (define (shortcut-visible-in-label? [mbar? #f]) #t) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index f289e429..f928be2e 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -99,7 +99,11 @@ (as-entry (lambda () (set! no-clicked? #t) - (gtk_toggle_button_set_active (list-ref radio-gtks i) #t) + (if (= i -1) + (let ([i (get-selection)]) + (unless (= i -1) + (gtk_toggle_button_set_active (list-ref radio-gtks i) #f))) + (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) (set! no-clicked? #f)))) (define/public (get-selection) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index d67ffc6a..e76fadfd 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -71,7 +71,6 @@ shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit - get-top-level-windows find-graphical-system-path check-for-break play-sound diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 246271c5..ba32858c 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -92,7 +92,6 @@ shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit - get-top-level-windows find-graphical-system-path check-for-break play-sound diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 8d790d2f..2c953a8b 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -14,7 +14,6 @@ play-sound check-for-break find-graphical-system-path - get-top-level-windows register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? @@ -68,7 +67,6 @@ (define-unimplemented play-sound) (define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented get-top-level-windows) (define-unimplemented register-collecting-blit) (define-unimplemented unregister-collecting-blit) (define-unimplemented shortcut-visible-in-label?) diff --git a/collects/mrlib/bitmap-label.rkt b/collects/mrlib/bitmap-label.rkt index 1d6a988d..08495da0 100644 --- a/collects/mrlib/bitmap-label.rkt +++ b/collects/mrlib/bitmap-label.rkt @@ -96,6 +96,7 @@ outside-margin (- (/ new-height 2) (/ img-height 2))) (send bitmap-dc set-bitmap #f) + new-bitmap))) (define (bitmap-label-maker text filename-or-bitmap) From 24ce75f30c297335469ec20494193558ce75cb89 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Jul 2010 12:58:33 -0600 Subject: [PATCH 093/462] fix racket/gui/dynamic and add multi-instance checks original commit: fa3d9cdf28bdba2643c54025fee1fcc7dab84376 --- collects/mred/private/wx/common/queue.rkt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 84f20776..0eb66a2d 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -38,6 +38,15 @@ queue-quit-event) +;; ------------------------------------------------------------ +;; This module must be instantiated only once: + +(define-mz scheme_register_process_global (_fun _string _pointer -> _pointer)) +(let ([v (scheme_register_process_global "GRacket-support-initialized" + (cast 1 _scheme _pointer))]) + (when v + (error "cannot start GRacket a second time in the same process"))) + ;; ------------------------------------------------------------ ;; Create a Scheme evt that is ready when a queue is nonempty From 771d383be66136a3e5601446ebbc3e464acca565 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Jul 2010 09:16:05 -0500 Subject: [PATCH 094/462] fix mouse position conversion and canvas moving original commit: 75189fbdee90336e6a8b6f6c99f7d783eede407a --- collects/mred/private/wx/cocoa/canvas.rkt | 6 +- collects/mred/private/wx/cocoa/frame.rkt | 2 + collects/mred/private/wx/cocoa/panel.rkt | 23 ++++- collects/mred/private/wx/cocoa/window.rkt | 111 +++++++++++++--------- 4 files changed, 94 insertions(+), 48 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 57308051..2cc2f000 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -66,7 +66,8 @@ get-client-size is-shown-to-root? move get-x get-y - on-size) + on-size + register-as-child) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) @@ -120,6 +121,9 @@ (get-client-size xb yb) (send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox yb)))) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + (define/public (on-paint) (void)) (define/override (set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 4dc7edf4..3901d82d 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -145,6 +145,8 @@ (define/override (is-parent-enabled-to-root?) #t) + (define/override (is-view?) #f) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 097df99f..1906ceea 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -31,6 +31,28 @@ x y w h style label) + (inherit register-as-child) + + (define children null) + + (define/public (fix-dc) + (for ([child (in-list children)]) + (send child fix-dc))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (fix-dc)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) (super-new [parent parent] [cocoa @@ -39,4 +61,3 @@ initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) (make-NSSize w h))))] [no-show? (memq 'deleted style)])) - diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index e11beb05..07802b39 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -89,55 +89,57 @@ (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)] - [k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (string-ref str 0)))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [x (NSPoint-x pos)] - [y (NSPoint-y pos)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) - (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)))) + [str (tell #:type _NSString event characters)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (string-ref str 0)))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (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 (do-mouse-event wx event kind l? m? r?) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] - [pos (tell #:type _NSPoint event locationInWindow)] - [m (new mouse-event% - [event-type kind] - [left-down l?] - [middle-down m?] - [right-down r?] - [x (->long (NSPoint-x pos))] - [y (->long (send wx flip-client (NSPoint-y pos)))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))) + [pos (tell #:type _NSPoint event locationInWindow)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([m (new mouse-event% + [event-type kind] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))))) (define window% (class object% @@ -173,7 +175,14 @@ (define/public (show on?) (if on? (tellv (send parent get-cocoa-content) addSubview: cocoa) - (tellv cocoa removeFromSuperview))) + (tellv cocoa removeFromSuperview)) + (maybe-register-as-child parent on?)) + (define/public (maybe-register-as-child parent on?) + (void)) + (define/public (register-as-child parent on?) + (send parent register-child this on?)) + (define/public (register-child child on?) + (void)) (define/public (is-shown?) (and (tell cocoa superview) #t)) @@ -210,6 +219,16 @@ (- y (client-y-offset)))))) (define/public (client-y-offset) 0) + (define/public (is-view?) #t) + (define/public (window-point-to-view pos) + (let ([pos (if (is-view?) + (tell #:type _NSPoint (get-cocoa-content) + convertPoint: #:type _NSPoint pos + fromView: #f) + pos)]) + (values (NSPoint-x pos) + (flip-client (NSPoint-y pos))))) + (define/public (get-x) (->long (NSPoint-x (NSRect-origin (get-frame))))) (define/public (get-y) From a9d6a3cb6478d0fb0f02eb77c7384e31e630415c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Jul 2010 20:21:20 -0500 Subject: [PATCH 095/462] more consistent mouse events original commit: 54bee6314efb966d5f3d863021f52fff5f1a9b69 --- collects/mred/private/wx/cocoa/canvas.rkt | 13 ++++++- collects/mred/private/wx/cocoa/frame.rkt | 2 + collects/mred/private/wx/common/event.rkt | 2 +- collects/mred/private/wx/gtk/canvas.rkt | 4 +- collects/mred/private/wx/gtk/types.rkt | 17 +++++++- collects/mred/private/wx/gtk/window.rkt | 47 ++++++++++++++++++----- 6 files changed, 71 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 2cc2f000..0d93034c 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -129,12 +129,23 @@ (define/override (set-size x y w h) (do-set-size x y w h)) + (define tr 0) + (define/private (do-set-size x y w h) (super set-size x y w h) + (when tr + (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) + (set! tr #f)) (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0)) (- h (if hscroll? scroll-width 0)))] [pos (make-NSPoint 0 (if hscroll? scroll-width 0))]) - (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))) + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) + (set! tr (tell #:type _NSInteger + content-cocoa + addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) sz) + owner: content-cocoa + userData: #f + assumeInside: #:type _BOOL #f))) (when v-scroller (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect (make-NSRect diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3901d82d..f5834e10 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -110,6 +110,8 @@ (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) + (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) + (define/override (get-cocoa-content) (tell cocoa contentView)) (define/override (get-cocoa-window) cocoa) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index dd5c0f61..793c18de 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -64,7 +64,7 @@ (eq? et 'enter)) (def/public (leaving?) - (eq? et 'leaving)) + (eq? et 'leave)) (def/public (moving?) (and (eq? et 'motion) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index b32b2dbe..0fbec660 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -153,7 +153,9 @@ GDK_BUTTON_PRESS_MASK GDK_BUTTON_RELEASE_MASK GDK_POINTER_MOTION_MASK - GDK_FOCUS_CHANGE_MASK)) + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) GTK_CAN_FOCUS)) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 62cb6be1..49305bcf 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -16,7 +16,9 @@ _GdkEventKey _GdkEventKey-pointer (struct-out GdkEventKey) _GdkEventMotion _GdkEventMotion-pointer - (struct-out GdkEventMotion)) + (struct-out GdkEventMotion) + _GdkEventCrossing _GdkEventCrossing-pointer + (struct-out GdkEventCrossing)) (define _GdkWindow (_cpointer/null 'GdkWindow)) @@ -71,3 +73,16 @@ [device _GdkDevice] [x_root _double] [y_root _double])) + +(define-cstruct _GdkEventCrossing ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [x_root _double] + [y_root _double] + [mode _int] + [detail _int] + [focus _gboolean] + [state _uint])) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index f8d33dbb..e8e522a8 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -105,39 +105,59 @@ (define-signal-handler connect-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) - (do-button-event gtk event #f))) + (do-button-event gtk event #f #f))) (define-signal-handler connect-button-release "button-release-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) - (do-button-event gtk event #f))) + (do-button-event gtk event #f #f))) (define-signal-handler connect-pointer-motion "motion-notify-event" (_fun _GtkWidget _GdkEventMotion-pointer -> _gboolean) (lambda (gtk event) - (do-button-event gtk event #t))) + (do-button-event gtk event #t #f))) + +(define-signal-handler connect-enter "enter-notify-event" + (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #f #t))) + +(define-signal-handler connect-leave "leave-notify-event" + (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #f #t))) (define (connect-key-and-mouse gtk) (connect-key-press gtk) (connect-button-press gtk) (connect-button-release gtk) - (connect-pointer-motion gtk)) + (connect-pointer-motion gtk) + (connect-enter gtk) + (connect-leave gtk)) -(define (do-button-event gtk event motion?) +(define (do-button-event gtk event motion? crossing?) (let ([type (if motion? GDK_MOTION_NOTIFY - (GdkEventButton-type event))]) + (if crossing? + (GdkEventCrossing-type event) + (GdkEventButton-type event)))]) (unless (or (= type GDK_2BUTTON_PRESS) (= type GDK_3BUTTON_PRESS)) (let* ([wx (gtk->wx gtk)] [modifiers (if motion? (GdkEventMotion-state event) - (GdkEventButton-state event))] + (if crossing? + (GdkEventCrossing-state event) + (GdkEventButton-state event)))] [bit? (lambda (m v) (positive? (bitwise-and m v)))] [m (new mouse-event% [event-type (cond [(= type GDK_MOTION_NOTIFY) 'motion] + [(= type GDK_ENTER_NOTIFY) + 'enter] + [(= type GDK_LEAVE_NOTIFY) + 'leave] [(= type GDK_BUTTON_PRESS) (case (GdkEventButton-button event) [(1) 'left-down] @@ -151,13 +171,20 @@ [left-down (bit? modifiers GDK_BUTTON1_MASK)] [middle-down (bit? modifiers GDK_BUTTON2_MASK)] [right-down (bit? modifiers GDK_BUTTON2_MASK)] - [x (->long ((if motion? GdkEventMotion-x GdkEventButton-x) event))] - [y (->long ((if motion? GdkEventMotion-y GdkEventButton-y) event))] + [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 GdkEventButton-time) event)] + [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?) (begin From 10fbac433af3a64370393b667ebe54b8f41d6eff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Jul 2010 21:15:48 -0500 Subject: [PATCH 096/462] focus callbacks original commit: efb88aef4f656003741a3e6474848a78ce6425a3 --- collects/mred/private/wx/cocoa/canvas.rkt | 9 ++++++--- collects/mred/private/wx/cocoa/window.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 7 +++++-- collects/mred/private/wxcanvas.rkt | 6 ++++-- collects/mred/private/wxwindow.rkt | 11 ++++++++++- 5 files changed, 26 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 0d93034c..7a5e4ab3 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -40,7 +40,7 @@ (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) (make-NSSize 32000 32000)))) (tellv ctx restoreGraphicsState)))) - (send wx refresh)) + (send wx queue-paint)) (-a _void (viewWillMoveToWindow: [_id w]) (when wx (queue-window-event wx (lambda () (send wx fix-dc))))) @@ -77,7 +77,7 @@ (define canvas-style style) (define paint-queued? #f) - (define/override (refresh) + (define/public (queue-paint) ;; can be called from any thread, including the event-pump thread (unless paint-queued? (set! paint-queued? #t) @@ -85,6 +85,9 @@ (set! paint-queued? #f) (on-paint))))) + (define/override (refresh) + (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) + (define/override (get-cocoa-content) content-cocoa) (super-new @@ -108,7 +111,7 @@ (define dc (make-object dc% (make-graphics-context) 0 0 10 10)) - (refresh) + (queue-paint) (define/public (get-dc) dc) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 07802b39..041805ca 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -266,7 +266,7 @@ (define/public (set-focus) (let ([w (tell cocoa window)]) (when w - (tellv w makeFirstResponder: cocoa)))) + (tellv w makeFirstResponder: (get-cocoa-content))))) (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e8e522a8..bd0fbb6f 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -52,7 +52,8 @@ (define-gtk gtk_widget_size_request (_fun _GtkWidget _GtkRequisition-pointer -> _void)) (define-gtk gtk_widget_size_allocate (_fun _GtkWidget _GtkAllocation-pointer -> _void)) (define-gtk gtk_widget_set_size_request (_fun _GtkWidget _int _int -> _void)) -(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) ;; ---------------------------------------- @@ -105,6 +106,8 @@ (define-signal-handler connect-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) + (unless (gtk_widget_is_focus gtk) + (gtk_widget_grab_focus gtk)) (do-button-event gtk event #f #f))) (define-signal-handler connect-button-release "button-release-event" @@ -288,7 +291,7 @@ (define/public (drag-accept-files on?) (void)) (define/public (set-focus) - (gtk_widget_grab_focus gtk)) + (gtk_widget_grab_focus (get-client-gtk))) (define/public (set-cursor v) (void)) diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 38ec4ebd..60cc8549 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/collects/mred/private/wxcanvas.rkt @@ -215,7 +215,9 @@ #t (make-editor-canvas% (make-control% wx:editor-canvas% 0 0 #t #t))) - (inherit editor-canvas-on-scroll) + (inherit editor-canvas-on-scroll + set-no-expose-focus) (define/override (on-scroll e) (editor-canvas-on-scroll)) - (super-new)))) + (super-new) + (set-no-expose-focus)))) diff --git a/collects/mred/private/wxwindow.rkt b/collects/mred/private/wxwindow.rkt index 66ab6dff..be3d4766 100644 --- a/collects/mred/private/wxwindow.rkt +++ b/collects/mred/private/wxwindow.rkt @@ -180,7 +180,10 @@ [old-w -1] [old-h -1] [old-x -1] - [old-y -1]) + [old-y -1] + [expose-focus? #t]) + (public + [set-no-expose-focus (lambda () (set! expose-focus? #f))]) (override [on-drop-file (entry-point (lambda (f) @@ -210,6 +213,12 @@ (set! old-x x) (set! old-y y) (as-exit (lambda () (send mred on-move x y)))))))))))] + [on-set-focus (lambda () + (super on-set-focus) + (when expose-focus? (send (get-proxy) on-focus #t)))] + [on-kill-focus (lambda () + (super on-kill-focus) + (when expose-focus? (send (get-proxy) on-focus #f)))] [pre-on-char (lambda (w e) (or (super pre-on-char w e) (if (skip-subwindow-events?) From dc77ede76eacdce8d4cfb185d64ed259b61433f1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 23 Jul 2010 08:19:34 -0500 Subject: [PATCH 097/462] queue and paint repairs original commit: 5af3d96a5d5fc3a1edcc108a0754949c84e0ec7d --- collects/mred/private/wx/cocoa/canvas.rkt | 30 ++++++++++++++++++----- collects/mred/private/wx/cocoa/queue.rkt | 1 + collects/mred/private/wx/gtk/queue.rkt | 2 +- 3 files changed, 26 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7a5e4ab3..c7052e65 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -10,6 +10,7 @@ "types.rkt" "window.rkt" "dc.rkt" + "queue.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -40,7 +41,9 @@ (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) (make-NSSize 32000 32000)))) (tellv ctx restoreGraphicsState)))) - (send wx queue-paint)) + (send wx queue-paint) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)) (-a _void (viewWillMoveToWindow: [_id w]) (when wx (queue-window-event wx (lambda () (send wx fix-dc))))) @@ -76,15 +79,26 @@ (define canvas-style style) + ;; Avoid multiple queued paints: (define paint-queued? #f) + ;; To handle paint requests that happen while on-paint + ;; is being called already: + (define now-drawing? #f) + (define refresh-after-drawing? #f) + (define/public (queue-paint) ;; can be called from any thread, including the event-pump thread (unless paint-queued? (set! paint-queued? #t) (queue-window-event this (lambda () (set! paint-queued? #f) - (on-paint))))) - + (set! now-drawing? #t) + (fix-dc) + (on-paint) + (set! now-drawing? #f) + (when refresh-after-drawing? + (set! refresh-after-drawing? #f) + (refresh)))))) (define/override (refresh) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) @@ -312,9 +326,13 @@ (define/public (get-canvas-background) bg-col) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) - bg-col)) + (if now-drawing? + (begin + (set! refresh-after-drawing? #t) + #f) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col))) (define/public (do-scroll direction scroller) ;; Called from the Cocoa handler thread diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index a4d5f99d..dddec0df 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -19,6 +19,7 @@ set-eventspace-hook! set-front-hook! set-menu-bar-hooks! + post-dummy-event ;; from common/queue: current-eventspace diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 443f8739..e5cd5cf2 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -37,7 +37,7 @@ (define-glib g_main_context_query (_fun _GMainContext _int _pointer - _GPollFD-pointer + _pointer ;; GPollFD array _int -> _int)) From 979268b6789251adb7bf9db5262ee4dbe7165986 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 23 Jul 2010 13:27:43 -0500 Subject: [PATCH 098/462] fix frame activation and menu bars original commit: 152526045a80a3c1e45bf013b307c88b1add149e --- collects/mred/private/wx/cocoa/frame.rkt | 41 +++++++++++++++++++----- 1 file changed, 33 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index f5834e10..202e45fb 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -10,7 +10,8 @@ "queue.rkt" "menu-bar.rkt" "../../syntax.rkt" - "../common/queue.rkt") + "../common/queue.rkt" + "../../lock.rkt") (unsafe!) (objc-unsafe!) @@ -18,11 +19,13 @@ ;; ---------------------------------------- -(import-class NSWindow NSGraphicsContext NSMenu) +(import-class NSWindow NSGraphicsContext NSMenu + NSApplication NSAutoreleasePool) (define front #f) (define empty-mb (new menu-bar%)) +(define root-fake-frame #f) (define-objc-class MyWindow NSWindow #:mixins (FocusResponder KeyMouseResponder) @@ -48,12 +51,13 @@ [-a _void (windowDidBecomeMain: [_id notification]) (when wx (set! front wx) + (send wx install-mb) (queue-window-event wx (lambda () - (send wx install-mb) (send wx on-activate #t))))] [-a _void (windowDidResignMain: [_id notification]) (when wx (when (eq? front wx) (set! front #f)) + (send empty-mb install) (queue-window-event wx (lambda () (send wx on-activate #f))))]) @@ -130,10 +134,30 @@ (tellv cocoa setTitle: #:type _NSString label)) (define/public (direct-show on?) - (if on? - (tellv cocoa makeKeyAndOrderFront: #f) - (tellv cocoa orderOut: #f)) - (register-frame-shown this on?)) + (as-entry + (lambda () + (when (and (not on?) + (eq? front this)) + (set! front #f) + (send empty-mb install)) + (if on? + (tellv cocoa makeKeyAndOrderFront: #f) + (begin + (tellv cocoa orderOut: #f) + (let ([next + (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] + [wins (tell (tell NSApplication sharedApplication) orderedWindows)]) + (begin0 + (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) + (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) + (and (tell #:type _BOOL win isVisible) + win))) + (tellv pool release)))]) + (cond + [next (tellv next makeKeyWindow)] + [root-fake-frame (send root-fake-frame install-mb)] + [else (void)])))) + (register-frame-shown this on?)))) (define/override (show on?) (direct-show on?)) @@ -227,7 +251,8 @@ (def/public-unimplemented on-menu-command) (def/public-unimplemented on-mdi-activate) (def/public-unimplemented on-close) - (define/public (designate-root-frame) (void)) + (define/public (designate-root-frame) + (set! root-fake-frame this)) (def/public-unimplemented system-menu) (define/public (set-modified on?) From bbea1bbfe782afb765000b7f01a302c4a4067b24 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 23 Jul 2010 13:46:07 -0500 Subject: [PATCH 099/462] refresh and menu bar repairs original commit: 50d10998c020d5b7d206a53b087e84fb7914cc4a --- collects/mred/private/wx/cocoa/menu-bar.rkt | 11 +++-- collects/mred/private/wx/gtk/canvas.rkt | 49 +++++++++++++++------ 2 files changed, 44 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 1e18a9de..60eb4bb8 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -32,11 +32,15 @@ appName)))))) "MrEd")) +(define the-apple-menu #f) + (define-objc-class MyBarMenu NSMenu [] - ;; Disable automatic handling of keyboard shortcuts + ;; Disable automatic handling of keyboard shortcuts, except for + ;; the Apple menu (-a _BOOL (performKeyEquivalent: [_id evt]) - #f)) + (and the-apple-menu + (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) @@ -108,7 +112,8 @@ (add-one cocoa-mb apple) (tellv app setAppleMenu: apple) (tellv apple release) - (tellv app setMainMenu: cocoa-mb))) + (tellv app setMainMenu: cocoa-mb) + (set! the-apple-menu apple))) (defclass menu-bar% object% (define menus null) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 0fbec660..0b0cbf81 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -56,8 +56,7 @@ (when gc (gdk_draw_rectangle (g_object_get_window gtk) gc #t 0 0 32000 32000))) - (queue-window-event wx (lambda () - (send wx on-paint)))) + (send wx queue-paint)) #t) (define handle_expose (function-ptr handle-expose (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _gboolean))) @@ -171,6 +170,26 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events?) #t) + ;; Avoid multiple queued paints: + (define paint-queued? #f) + ;; To handle paint requests that happen while on-paint + ;; is being called already: + (define now-drawing? #f) + (define refresh-after-drawing? #f) + + (define/public (queue-paint) + ;; can be called from any thread, including the event-pump thread + (unless paint-queued? + (set! paint-queued? #t) + (queue-window-event this (lambda () + (set! paint-queued? #f) + (set! now-drawing? #t) + (on-paint) + (set! now-drawing? #f) + (when refresh-after-drawing? + (set! refresh-after-drawing? #f) + (refresh)))))) + (define/public (on-paint) (void)) (define/override (refresh) @@ -235,17 +254,21 @@ (define/public (get-canvas-background) bg-col) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) - (if clear-bg? - (let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) - (unless gc - (let ([w (g_object_get_window gtk)]) - (set! gc (gdk_gc_new w)))) - (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 - (conv (color-red bg-col)) - (conv (color-green bg-col)) - (conv (color-blue bg-col)))) - gc) - #f)) + (if now-drawing? + (begin + (set! refresh-after-drawing? #t) + #f) + (if clear-bg? + (let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) + (unless gc + (let ([w (g_object_get_window gtk)]) + (set! gc (gdk_gc_new w)))) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 + (conv (color-red bg-col)) + (conv (color-green bg-col)) + (conv (color-blue bg-col)))) + gc) + #f))) (def/public-unimplemented set-background-to-gray) From b2de1b0624d5b0c04d4c24bd46f608834a1a63cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 24 Jul 2010 16:44:41 -0500 Subject: [PATCH 100/462] frame, dialog, and stock-icon repairs original commit: 2f2341be6ff05b603e1ee742f352ec45851528a6 --- collects/mred/private/wx/cocoa/message.rkt | 42 ++++++++++-- collects/mred/private/wx/cocoa/window.rkt | 14 +++- collects/mred/private/wx/common/freeze.rkt | 79 ++++++++++++---------- collects/mred/private/wx/gtk/canvas.rkt | 4 +- collects/mred/private/wx/gtk/dialog.rkt | 21 +++++- collects/mred/private/wx/gtk/frame.rkt | 27 ++++++++ collects/mred/private/wx/gtk/message.rkt | 8 ++- collects/mred/private/wx/gtk/window.rkt | 4 +- 8 files changed, 150 insertions(+), 49 deletions(-) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index bca6680f..272a5cd0 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -2,6 +2,7 @@ (require scheme/class scheme/foreign ffi/objc + racket/draw/bitmap "../../syntax.rkt" "item.rkt" "utils.rkt" @@ -14,7 +15,20 @@ ;; ---------------------------------------- -(import-class NSTextField NSImageView) +(import-class NSTextField NSImageView NSWorkspace) + +(define _OSType _uint32) + +(define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id)) + +(define (get-app-icon) + (tell (tell NSWorkspace sharedWorkspace) + iconForFile: + (tell (tell (tell NSWorkspace sharedWorkspace) + activeApplication) + objectForKey: + #:type _NSString + "NSApplicationPath"))) (defclass message% item% (init parent label @@ -25,7 +39,21 @@ (super-new [parent parent] [cocoa (let* ([label (cond [(string? label) label] - [(symbol? label) (format "<~a>" label)] + [(symbol? label) + (let ([icon + (if (eq? label 'app) + (get-app-icon) + (let ([id (integer-bytes->integer + (case label + [(caution) #"caut"] + [(stop) #"stop"]) + #f + #t)]) + (tell (tell NSWorkspace sharedWorkspace) + iconForFileType: + (NSFileTypeForHFSTypeCode id))))]) + (tellv icon setSize: #:type _NSSize (make-NSSize 64 64)) + icon)] [(send label ok?) label] [else ""])] [cocoa @@ -43,11 +71,15 @@ (tellv cocoa setTitleWithMnemonic: #:type _NSString label) (tellv cocoa sizeToFit)] [else - (tellv cocoa setImage: (bitmap->image label)) + (tellv cocoa setImage: (if (label . is-a? . bitmap%) + (bitmap->image label) + label)) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) - (make-NSSize (send label get-width) - (send label get-height))))]) + (if (label . is-a? . bitmap%) + (make-NSSize (send label get-width) + (send label get-height)) + (tell #:type _NSSize label size))))]) cocoa)] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 041805ca..b6c07274 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -318,7 +318,15 @@ (define/public (center a b) (void)) (def/public-unimplemented refresh) - (def/public-unimplemented screen-to-client) + (define/public (screen-to-client xb yb) + (let ([p (tell #:type _NSPoint (get-cocoa-content) + convertPointFromBase: #:type _NSPoint + (tell #:type _NSPoint (get-cocoa-window) + convertScreenToBase: + #:type _NSPoint (make-NSPoint (unbox xb) + (send (get-wx-window) flip-screen (unbox yb)))))]) + (set-box! xb (inexact->exact (floor (NSPoint-x p)))) + (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) (define/public (client-to-screen xb yb) (let* ([p (tell #:type _NSPoint (get-cocoa-window) @@ -328,8 +336,8 @@ convertPointToBase: #:type _NSPoint (make-NSPoint (unbox xb) (flip-client (unbox yb)))))]) (let ([new-y (send (get-wx-window) flip-screen (NSPoint-y p))]) - (set-box! xb (NSPoint-x p)) - (set-box! yb new-y)))) + (set-box! xb (inexact->exact (floor (NSPoint-x p)))) + (set-box! yb (inexact->exact (floor new-y)))))) (def/public-unimplemented fit) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 0183381f..2dabeb93 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -15,20 +15,20 @@ (define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer) #:c-id scheme_set_on_atomic_timeout) -(define freezer-box (make-parameter #f)) +(define freezer-box (make-parameter null)) (define freeze-tag (make-continuation-prompt-tag)) ;; Runs `thunk' atomically, but cooperates with ;; `constrained-reply' to continue a frozen ;; computation in non-atomic mode. (define (call-as-unfreeze-point thunk) - (let ([b (box #f)]) + (let ([b (box null)]) (parameterize ([freezer-box b]) ;; In atomic mode: (as-entry (lambda () (thunk))) ;; Out of atomic mode: - (let ([k (unbox b)]) - (when k + (let ([l (unbox b)]) + (for ([k (in-list (reverse l))]) (call-with-continuation-prompt ; to catch aborts (lambda () (call-with-continuation-prompt @@ -41,36 +41,41 @@ (let ([now (current-inexact-milliseconds)]) (lambda () ((current-inexact-milliseconds) . > . (+ now 200))))]) - (unless (freezer-box) - (log-error "internal error: constrained-reply not within an unfreeze point")) - (if (eq? (current-thread) (eventspace-handler-thread es)) - (let* ([prev #f] - [ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) - (scheme_call_with_composable_no_dws - (lambda (proc) - (set-box! (freezer-box) proc) - (scheme_restore_on_atomic_timeout prev) - (scheme_abort_continuation_no_dws - freeze-tag - (lambda () default))) - freeze-tag) - (void)))] - [old (scheme_set_on_atomic_timeout handler)]) - (with-holding - handler - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt ; for composable continuation - (lambda () - (set! prev old) - (set! ready? #t) - (begin0 - (parameterize ([freezer-box #f]) - (thunk)) - (scheme_restore_on_atomic_timeout prev))) - freeze-tag))))) - (begin - (log-error "internal error: wrong eventspace for constrained event handling\n") - default))) + (let ([b (freezer-box)]) + (unless b + (log-error "internal error: constrained-reply not within an unfreeze point")) + (if (eq? (current-thread) (eventspace-handler-thread es)) + (if (pair? b) + ;; already suspended, so push this work completely: + (set-box! b (cons thunk (unbox b))) + ;; try to do some work: + (let* ([prev #f] + [ready? #f] + [handler (lambda () + (when (and ready? (should-give-up?)) + (scheme_call_with_composable_no_dws + (lambda (proc) + (set-box! (freezer-box) (cons proc (freezer-box))) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))] + [old (scheme_set_on_atomic_timeout handler)]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev old) + (set! ready? #t) + (begin0 + (parameterize ([freezer-box #f]) + (thunk)) + (scheme_restore_on_atomic_timeout prev))) + freeze-tag)))))) + (begin + (log-error "internal error: wrong eventspace for constrained event handling\n") + default)))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 0b0cbf81..f3e03279 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -173,7 +173,9 @@ ;; Avoid multiple queued paints: (define paint-queued? #f) ;; To handle paint requests that happen while on-paint - ;; is being called already: + ;; is being called already. kProbably doesn't happen, + ;; because expose callabcks should be in the right + ;; eventspace. (define now-drawing? #f) (define refresh-after-drawing? #f) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 6917c412..9d3e4ee8 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -1,12 +1,23 @@ #lang scheme/base (require scheme/class + ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" - "frame.rkt") + "types.rkt" + "utils.rkt" + "frame.rkt") (provide dialog%) +(define GTK_WIN_POS_CENTER 1) +(define GTK_WIN_POS_CENTER_ON_PARENT 4) + +(define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void)) + (defclass dialog% frame% + (inherit get-gtk + get-parent) + (super-new [is-dialog? #t]) (define close-sema #f) @@ -18,6 +29,14 @@ (set! close-sema #f))) (super direct-show on?)) + (define/override (center dir wrt) + (if #f ; (eq? dir 'both) + (gtk_window_set_position (get-gtk) + (if (get-parent) + GTK_WIN_POS_CENTER_ON_PARENT + GTK_WIN_POS_CENTER)) + (super center dir wrt))) + (define/override (show on?) (if on? (unless close-sema diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 5c35cc8f..12b08123 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -8,6 +8,7 @@ "window.rkt" "client-window.rkt" "widget.rkt" + "procs.rkt" "../common/queue.rkt") (unsafe!) @@ -25,6 +26,7 @@ (define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_window_maximize (_fun _GtkWidget -> _void)) (define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void)) (define (handle-delete gtk) (let ([wx (gtk->wx gtk)]) @@ -113,6 +115,31 @@ (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) (void)) + (define/override (center dir wrt) + (let ([w-box (box 0)] + [h-box (box 0)] + [sw-box (box 0)] + [sh-box (box 0)]) + (get-size w-box h-box) + (display-size sw-box sh-box #t) + (let* ([sw (unbox sw-box)] + [sh (unbox sh-box)] + [fw (unbox w-box)] + [fh (unbox h-box)]) + (set-top-position (if (or (eq? dir 'both) + (eq? dir 'horizontal)) + (/ (- sw fw) 2) + -11111) + (if (or (eq? dir 'both) + (eq? dir 'vertical)) + (/ (- sh fh) 2) + -11111))))) + + (define/override (set-top-position x y) + (gtk_widget_set_uposition gtk + (if (= x -11111) -2 x) + (if (= y -11111) -2 y))) + (define/override (get-size wb hb) (let-values ([(w h) (gtk_window_get_size gtk)]) (set-box! wb w) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 0ce0b70d..fdd2397c 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -19,6 +19,7 @@ (define-gtk gtk_label_new (_fun _string -> _GtkWidget)) (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -38,6 +39,8 @@ (gtk_label_set_text_with_mnemonic l s))) l)) +(define icon-size 6) ; = GTK_ICON_SIZE_DIALOG + (defclass message% item% (init parent label x y @@ -49,7 +52,10 @@ (not label)) (gtk_label_new_with_mnemonic (or label "")) (if (symbol? label) - (gtk_label_new (format "<~a>" label)) + (case label + [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] + [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] + [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]) (gtk_image_new_from_pixbuf (bitmap->pixbuf label))))] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index bd0fbb6f..e37b8f50 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -235,7 +235,9 @@ (unless (= h -1) (set! save-h h)) (if parent (send parent set-child-size gtk save-x save-y save-w save-h) - (set-child-size gtk save-x save-y save-w save-h))) + (set-child-size gtk save-x save-y save-w save-h)) + (set-top-position save-x save-y)) + (define/public (set-top-position x y) (void)) (define/public (set-child-size child-gtk x y w h) (gtk_widget_set_size_request child-gtk w h) (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) From 97fc56d722d16d2d00510852b831c501e0a83aac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 24 Jul 2010 18:33:36 -0500 Subject: [PATCH 101/462] more repairs to constrained-reply and menu-bar handling original commit: 238650e3270706715af4abc43639ffa5a98e188e --- collects/mred/private/wx/cocoa/menu-bar.rkt | 9 +--- collects/mred/private/wx/cocoa/queue.rkt | 57 +++++++++++---------- collects/mred/private/wx/common/freeze.rkt | 5 +- 3 files changed, 34 insertions(+), 37 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 60eb4bb8..68b09544 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -59,14 +59,7 @@ (and (<= x (NSPoint-x p) (+ x w)) (<= (- y h) (NSPoint-y p) y))))))) -(define suspend-menu-bar - (lambda (on?) - ;; We don't actually suspend anything, since the MrEd layer - ;; will drop events that shouldn't be delivered. - (void))) - -(set-menu-bar-hooks! in-menu-bar-range - suspend-menu-bar) +(set-menu-bar-hooks! in-menu-bar-range) ;; Init menu bar (let ([app (tell NSApplication sharedApplication)] diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index dddec0df..08f9b7f8 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -162,42 +162,47 @@ (define (set-front-hook! proc) (set! front-hook proc)) (define in-menu-bar-range? (lambda (p) #f)) -(define suspend-menu-bar (lambda (suspend?) (void))) -(define (set-menu-bar-hooks! r? s) - (set! in-menu-bar-range? r?) - (set! suspend-menu-bar s)) +(define (set-menu-bar-hooks! r?) + (set! in-menu-bar-range? r?)) (define events-suspended? #f) +(define was-menu-bar #f) (define (check-menu-bar-click evt) - (when (and evt - (= 14 (tell #:type _NSUInteger evt type)) - (= 7 (tell #:type _short evt subtype)) - (not (tell evt window)) - (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) - ;; Mouse down in the menu bar: - (let-values ([(f e) (front-hook)]) - (when e - ;; Don't handle further events until we've made an effort - ;; at on-demand notifications. - (set! events-suspended? #t) - (let ([t (thread (lambda () - (sleep 2) - ;; on-demand took too long, so disable the menu bar - ;; until the application can catch up - (suspend-menu-bar #t) - (set! events-suspended? #f)))]) - (queue-event e (lambda () - (send f on-menu-click) - (set! events-suspended? #f) - (kill-thread t)))))))) + (if (and evt + (= 14 (tell #:type _NSUInteger evt type)) + (= 7 (tell #:type _short evt subtype)) + (not (tell evt window)) + (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) + ;; Mouse down in the menu bar: + (let-values ([(f e) (front-hook)]) + (when e + ;; Avoid spiral of on-demand calls: + (unless (and was-menu-bar + (eq? e (weak-box-value was-menu-bar))) + ;; Don't handle further events until we've made an effort + ;; at on-demand notifications. + (set! was-menu-bar (make-weak-box e)) + (set! events-suspended? #t) + (let* ([c (make-custodian)] + [t (parameterize ([current-custodian c]) + (thread (lambda () + (sleep 2) + ;; on-demand took too long, so wait + ;; until the application can catch up + (set! events-suspended? #f))))]) + (queue-event e (lambda () + (send f on-menu-click) + (set! events-suspended? #f) + (custodian-shutdown-all c))))))) + (set! was-menu-bar #f))) ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (when (and events-suspended? wait?) - (suspend-menu-bar #t) + (set! was-menu-bar #f) (set! events-suspended? #f)) (begin0 (let ([evt (if events-suspended? diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 2dabeb93..4c03a4c4 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -61,15 +61,14 @@ freeze-tag (lambda () default))) freeze-tag) - (void)))] - [old (scheme_set_on_atomic_timeout handler)]) + (void)))]) (with-holding handler (call-with-continuation-prompt ; to catch aborts (lambda () (call-with-continuation-prompt ; for composable continuation (lambda () - (set! prev old) + (set! prev (scheme_set_on_atomic_timeout handler)) (set! ready? #t) (begin0 (parameterize ([freezer-box #f]) From 2e9088f07a8965e65e92a2f558d40c146b575aac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 25 Jul 2010 12:05:01 -0500 Subject: [PATCH 102/462] canvas and frame repairs original commit: ac6139345d59448cb8d060a95bf9b0da43c58f69 --- collects/mred/private/wx/cocoa/canvas.rkt | 22 +++++++++++++++------- collects/mred/private/wx/gtk/frame.rkt | 4 ++-- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index c7052e65..b18587ed 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -79,6 +79,8 @@ (define canvas-style style) + (define is-visible? #f) + ;; Avoid multiple queued paints: (define paint-queued? #f) ;; To handle paint requests that happen while on-paint @@ -92,13 +94,14 @@ (set! paint-queued? #t) (queue-window-event this (lambda () (set! paint-queued? #f) - (set! now-drawing? #t) - (fix-dc) - (on-paint) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh)))))) + (when is-visible? + (set! now-drawing? #t) + (fix-dc) + (on-paint) + (set! now-drawing? #f) + (when refresh-after-drawing? + (set! refresh-after-drawing? #f) + (refresh))))))) (define/override (refresh) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) @@ -148,6 +151,11 @@ (define tr 0) + (define/override (show on?) + (set! is-visible? on?) + ;; FIXME: what if we're in the middle of an on-paint? + (super show on?)) + (define/private (do-set-size x y w h) (super set-size x y w h) (when tr diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 12b08123..8e3c0ecb 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -128,11 +128,11 @@ [fh (unbox h-box)]) (set-top-position (if (or (eq? dir 'both) (eq? dir 'horizontal)) - (/ (- sw fw) 2) + (quotient (- sw fw) 2) -11111) (if (or (eq? dir 'both) (eq? dir 'vertical)) - (/ (- sh fh) 2) + (quotient (- sh fh) 2) -11111))))) (define/override (set-top-position x y) From e4ffd5e6c19c8e61b53996e62a9706f9a59eb7aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 Jul 2010 15:53:47 -0500 Subject: [PATCH 103/462] default buttons and Cocoa clipboard original commit: 0723c4f647921b3d3342e531d017b414d0f5530e --- collects/mred/private/wx/cocoa/button.rkt | 3 +- collects/mred/private/wx/cocoa/choice.rkt | 1 + collects/mred/private/wx/cocoa/clipboard.rkt | 71 +++++++++++++++++++- collects/mred/private/wx/cocoa/gauge.rkt | 1 + collects/mred/private/wx/cocoa/item.rkt | 6 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 2 +- collects/mred/private/wx/cocoa/message.rkt | 1 + collects/mred/private/wx/cocoa/queue.rkt | 5 +- collects/mred/private/wx/cocoa/radio-box.rkt | 1 + collects/mred/private/wx/cocoa/slider.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 2 - collects/mred/private/wx/common/freeze.rkt | 11 +-- collects/mred/private/wx/gtk/button.rkt | 1 + collects/mred/private/wx/gtk/choice.rkt | 1 + collects/mred/private/wx/gtk/item.rkt | 7 +- collects/mred/private/wx/gtk/list-box.rkt | 1 + collects/mred/private/wx/gtk/radio-box.rkt | 1 + collects/mred/private/wx/gtk/slider.rkt | 1 + 18 files changed, 105 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 8410b59d..54b379a9 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -94,7 +94,8 @@ (super-new [parent parent] [cocoa cocoa] - [no-show? (memq 'deleted style)]) + [no-show? (memq 'deleted style)] + [callback cb]) (when (memq 'border style) (tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell))) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 8d6fbbc7..98b1f869 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -48,6 +48,7 @@ (tellv cocoa setTarget: cocoa) (tellv cocoa setAction: #:type _SEL (selector clicked:)) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define callback cb) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index 76a531e5..c77307b2 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -1,12 +1,81 @@ #lang scheme/base (require scheme/class + ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt" + "../common/bstr.rkt" "../../syntax.rkt") (provide clipboard-driver% has-x-selection?) +(import-class NSPasteboard NSArray NSData) +(import-protocol NSPasteboardOwner) + (define (has-x-selection?) #f) +(define (map-type s) + (cond + [(string=? s "TEXT") "public.utf8-plain-text"] + [else (string-append "org.racket-lang." s)])) + +(define (unmap-type s) + (cond + [(string=? s "public.utf8-plain-text") "TEXT"] + [(regexp-match #rx"^org[.]racket-lang[.](.*)$" s) + => (lambda (m) (cadr m))] + [else s])) + (defclass clipboard-driver% object% (init x-selection?) ; always #f - (super-new)) + (super-new) + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (let ([c (tell #:type _NSInteger (tell NSPasteboard generalPasteboard) + changeCount)]) + (if (= c counter) + client + (begin + (set! client #f) + #f))))) + + (define/public (set-client c types) + (let ([pb (tell NSPasteboard generalPasteboard)] + [a (tell NSArray arrayWithObjects: + #:type (_list i _NSString) (map map-type types) + count: #:type _NSUInteger (length types))]) + (set! counter (tell #:type _NSInteger pb clearContents)) + (set! client c) + (for ([type (in-list types)]) + (let* ([bstr (send c get-data type)] + [data (tell NSData + dataWithBytes: #:type _bytes bstr + length: #:type _NSUInteger (bytes-length bstr))]) + (tellv (tell NSPasteboard generalPasteboard) + setData: data + forType: #:type _NSString (map-type type)))))) + + (define/public (get-data-for-type type) + (log-error "didn't expect clipboard data request")) + + (define/public (get-text-data) + (let ([bstr (get-data "TEXT")]) + (and bstr + (bytes->string/utf-8 bstr #\?)))) + + (define/public (get-data type) + (let* ([pb (tell NSPasteboard generalPasteboard)] + [data (tell pb dataForType: #:type _NSString (map-type type))]) + (and data + (let ([len (tell #:type _NSUInteger data length)] + [bstr (tell #:type _pointer data bytes)]) + (scheme_make_sized_byte_string bstr len 1)))))) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index adcbde13..db13bb78 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -42,6 +42,7 @@ (if vert? 32 24)))) (tellv cocoa sizeToFit) cocoa)] + [callback void] [no-show? (memq 'deleted style)]) (define cocoa (get-cocoa)) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index bcc15110..ec6e7074 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -18,6 +18,8 @@ (defclass item% window% (inherit get-cocoa) + (init-field callback) + (define/public (get-cocoa-control) (get-cocoa)) (define/override (enable on?) @@ -28,9 +30,11 @@ (define/override (gets-focus?) (tell #:type _BOOL (get-cocoa) canBecomeKeyView)) + (define/public (command e) + (callback this e)) + (def/public-unimplemented set-label) (def/public-unimplemented get-label) - (def/public-unimplemented command) (super-new) (define/public (init-font cocoa font) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 68b09544..aa35cc65 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -83,7 +83,7 @@ (tellv apple addItem: item) (tellv item release)))]) (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) - (std "Preferences..." #f) + (std "Preferences..." (selector openPreferences:)) (tellv apple addItem: (tell NSMenuItem separatorItem)) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) (tellv app setServicesMenu: services) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 272a5cd0..1d1f7526 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -81,6 +81,7 @@ (send label get-height)) (tell #:type _NSSize label size))))]) cocoa)] + [callback void] [no-show? (memq 'deleted style)]) (define/override (set-label label) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 08f9b7f8..3211db05 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -35,7 +35,10 @@ [] [-a _BOOL (applicationShouldTerminate: [_id app]) (queue-quit-event) - #f]) + #f] + [-a _BOOL (openPreferences: [_id app]) + (log-error "prefs") + #t]) (tellv app finishLaunching) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index d2a6df58..464259ad 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -98,6 +98,7 @@ (tellv cocoa setTarget: cocoa) (tellv cocoa setAction: #:type _SEL (selector clicked:)) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define count (length labels)) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index d9c06a31..45c03b5b 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -54,6 +54,7 @@ (tellv cocoa setContinuous: #:type _BOOL #t) ; (tellv cocoa sizeToFit) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define cocoa (get-cocoa)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b6c07274..cde3f9e5 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -22,8 +22,6 @@ ;; ---------------------------------------- -(import-class NSArray) - (define-objc-mixin (FocusResponder Superclass) [wx] [-a _BOOL (acceptsFirstResponder) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 4c03a4c4..d5dc26d0 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -70,10 +70,13 @@ (lambda () (set! prev (scheme_set_on_atomic_timeout handler)) (set! ready? #t) - (begin0 - (parameterize ([freezer-box #f]) - (thunk)) - (scheme_restore_on_atomic_timeout prev))) + (dynamic-wind + void + (lambda () + (parameterize ([freezer-box #f]) + (thunk))) + (lambda () + (scheme_restore_on_atomic_timeout prev)))) freeze-tag)))))) (begin (log-error "internal error: wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index dbcb1e03..8277ffe0 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -52,6 +52,7 @@ gtk)] [else (gtk_new_with_mnemonic "")])] + [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 8af7770d..ccd5c549 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -59,6 +59,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks (list button-gtk)] + [callback cb] [no-show? (memq 'deleted style)]) (gtk_combo_box_set_active gtk 0) diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt index 556f5c94..b2fa259a 100644 --- a/collects/mred/private/wx/gtk/item.rkt +++ b/collects/mred/private/wx/gtk/item.rkt @@ -8,6 +8,8 @@ (defclass item% window% (inherit get-client-gtk) + (init-field [callback void]) + (super-new) (let ([client-gtk (get-client-gtk)]) @@ -16,7 +18,10 @@ (def/public-unimplemented set-label) (def/public-unimplemented get-label) - (def/public-unimplemented command)) + + (define/public (command e) + (callback this e))) + diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 6d6c3563..a744d4ae 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -109,6 +109,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk selection)] + [callback cb] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index f928be2e..30952d0c 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -66,6 +66,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks radio-gtks] + [callback cb] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 337c043e..3a273718 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -40,6 +40,7 @@ [gtk (if (memq 'vertical style) (gtk_vscale_new #f) (gtk_hscale_new #f))] + [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) From fb772f19e82d259a3395f76e6079e25f99a60a16 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 06:43:38 -0500 Subject: [PATCH 104/462] support general transformation matrix original commit: d7289c253f4e561a416a4dfa8c321f9effb4af26 --- collects/tests/gracket/draw.rkt | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 11ad0628..381c31c8 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -226,7 +226,9 @@ [save-filename #f] [save-file-format #f] [clip 'none] - [current-alpha 1.0]) + [current-alpha 1.0] + [current-rotation 0.0] + [current-skew? #f]) (send hp0 stretchable-height #f) (send hp stretchable-height #f) (send hp2.5 stretchable-height #f) @@ -965,6 +967,10 @@ (send dc start-page) (send dc set-alpha current-alpha) + (send dc set-rotation current-rotation) + (send dc set-initial-matrix (if current-skew? + (vector 1 0 0.2 1 3 0) + (vector 1 0 0 1 0 0))) (if clip-pre-scale? (begin @@ -1243,7 +1249,18 @@ (unless (= a current-alpha) (set! current-alpha a) (send canvas refresh)))) - 10 '(horizontal plain)))) + 10 '(horizontal plain)) + (make-object slider% "Rotation" 0 100 hp4 + (lambda (s e) + (let ([a (* pi 1/4 (/ (send s get-value) 100.0))]) + (unless (= a current-rotation) + (set! current-rotation a) + (send canvas refresh)))) + 0 '(horizontal plain)) + (make-object check-box% "Skew" hp4 + (lambda (c e) + (set! current-skew? (send c get-value)) + (send canvas refresh))))) (send f show #t)) From 285f974be7c842bc708a23d125eaa78abb198da6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 07:17:01 -0500 Subject: [PATCH 105/462] fix canvases in tab panels original commit: 82c0a1cc29a07b151a0862102ef883fb56b35266 --- collects/mred/private/wx/cocoa/panel.rkt | 46 +++++++++++----------- collects/mred/private/wx/gtk/canvas.rkt | 15 ++++++- collects/mred/private/wx/gtk/dc.rkt | 9 +++-- collects/mred/private/wx/gtk/panel.rkt | 26 +++++++++++- collects/mred/private/wx/gtk/tab-panel.rkt | 7 +++- collects/mred/private/wx/gtk/window.rkt | 13 +++++- 6 files changed, 82 insertions(+), 34 deletions(-) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 1906ceea..0c34141c 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -16,12 +16,35 @@ (define (panel-mixin %) (class % + (inherit register-as-child) + (define lbl-pos 'horizontal) + (define children null) + (super-new) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) + (define/public (fix-dc) + (for ([child (in-list children)]) + (send child fix-dc))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (fix-dc)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) + (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor))) @@ -31,29 +54,6 @@ x y w h style label) - (inherit register-as-child) - - (define children null) - - (define/public (fix-dc) - (for ([child (in-list children)]) - (send child fix-dc))) - - (define/override (set-size x y w h) - (super set-size x y w h) - (fix-dc)) - - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - - (define/override (register-child child on?) - (let ([now-on? (and (memq child children) #t)]) - (unless (eq? on? now-on?) - (set! children - (if on? - (cons child children) - (remq child children)))))) - (super-new [parent parent] [cocoa (as-objc-allocation diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index f3e03279..738ccbb6 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -84,7 +84,8 @@ [ignored-name #f] [gl-config #f]) - (inherit get-gtk set-size get-client-size) + (inherit get-gtk set-size get-size get-client-size + on-size register-as-child) (define client-gtk (gtk_drawing_area_new)) (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) @@ -196,9 +197,19 @@ (define/override (refresh) (gtk_widget_queue_draw client-gtk)) + + (define/public (reset-child-dcs) + (send dc reset-dc #t)) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) (define/override (internal-on-client-size w h) - (send dc reset-dc-size)) + (send dc reset-dc #f)) + (define/override (on-client-size w h) + (let ([xb (box 0)] + [yb (box 0)]) + (get-size xb yb) + (on-size (unbox xb) (unbox yb)))) (define/public (show-scrollbars h? v?) (when hscroll-gtk diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 018db564..f957b182 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -9,13 +9,13 @@ racket/draw/local ffi/unsafe/alloc) -(provide dc% reset-dc-size) +(provide dc% reset-dc) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) (define-local-member-name - reset-dc-size) + reset-dc) (define dc-backend% (class default-dc-backend% @@ -31,8 +31,9 @@ (set! c (gdk_cairo_create w)) c)))) - (define/public (reset-dc-size) - (when (eq? 'windows (system-type)) + (define/public (reset-dc force?) + (when (or force? + (eq? 'windows (system-type))) ;; FIXME: ensure that the dc is not in use (as-entry (lambda () diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 3f6bda3e..5cee2fcc 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -17,12 +17,36 @@ (define (panel-mixin %) (class % - (define lbl-pos 'vertical) + (inherit register-as-child) + + (define lbl-pos 'horizontal) + (define children null) + (super-new) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) + (define/public (reset-child-dcs) + (when (pair? children) + (for ([child (in-list children)]) + (send child reset-child-dcs)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (reset-child-dcs)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) + (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor))) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 1ce9cc41..a190e4c4 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -45,7 +45,8 @@ style labels) - (inherit set-size set-auto-size get-gtk) + (inherit set-size set-auto-size get-gtk + reset-child-dcs) (define gtk (gtk_notebook_new)) ;; Reparented so that it's always in the current page's bin: @@ -56,7 +57,9 @@ (define (select-bin bin-gtk) (set! current-bin-gtk bin-gtk) - (gtk_box_pack_start bin-gtk client-gtk #t #t 0)) + (gtk_box_pack_start bin-gtk client-gtk #t #t 0) + ;; re-parenting can change the underlying window dc: + (reset-child-dcs)) (define pages (for/list ([lbl labels]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e37b8f50..7e9f50be 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -255,7 +255,8 @@ (if on? (gtk_widget_show gtk) (gtk_widget_hide gtk)) - (set! shown? (and on? #t))) + (set! shown? (and on? #t)) + (maybe-register-as-child parent on?)) (define/public (show on?) (direct-show on?)) (define/public (is-shown?) shown?) @@ -325,8 +326,16 @@ (define/public (on-char e) (void)) (define/public (on-event e) (void)) + (define/public (on-size w h) (void)) + + (define/public (maybe-register-as-child parent on?) + (void)) + (define/public (register-as-child parent on?) + (send parent register-child this on?)) + (define/public (register-child child on?) + (void)) + (def/public-unimplemented on-drop-file) - (def/public-unimplemented on-size) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) (def/public-unimplemented popup-menu) From d4385a71742ad982aba0968d49e8db42c01c5850 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 10:14:54 -0500 Subject: [PATCH 106/462] popup menus original commit: bc7d3d737614f47acb54b2fd4376e6a581bfe3e0 --- collects/mred/private/wx/cocoa/menu.rkt | 49 ++++++++++---- collects/mred/private/wx/cocoa/window.rkt | 23 ++++--- collects/mred/private/wx/common/event.rkt | 6 +- collects/mred/private/wx/gtk/frame.rkt | 7 +- collects/mred/private/wx/gtk/menu.rkt | 80 +++++++++++++++++++++-- collects/mred/private/wx/gtk/window.rkt | 61 ++++++++++------- 6 files changed, 174 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 7bf877ca..804254c1 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -3,10 +3,11 @@ scheme/foreign (only-in scheme/list drop take) ffi/objc - "../../syntax.rkt" - "utils.rkt" - "types.rkt" - "window.rkt") + "../common/event.rkt" + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "window.rkt") (unsafe!) (objc-unsafe!) @@ -28,7 +29,7 @@ (define cocoa #f) (define cocoa-menu #f) - (define/public (install cocoa-parent label) + (define/public (create-menu label) (unless cocoa (set! cocoa (as-objc-allocation @@ -46,16 +47,42 @@ (if item (send (mitem-item item) install cocoa-menu) (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) - items)) + items))) + + (define/public (install cocoa-parent label) + (create-menu label) (tellv cocoa-parent addItem: cocoa)) + (define popup-box #f) + + (define/public (do-popup v x y queue-cb) + (unless (null? items) + (create-menu "menu") + (let ([b (box #f)]) + (set! popup-box b) + (tellv cocoa-menu + popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0) + atLocation: #:type _NSPoint (make-NSPoint x y) + inView: v) + (set! popup-box #f) + (let* ([i (unbox b)] + [e (new popup-event% [event-type 'menu-popdown])]) + (send e set-menu-id i) + (queue-cb (lambda () (callback this e))))))) + (define/public (item-selected menu-item) ;; called in Cocoa thread - (let ([top (get-top-parent)]) - (when top - (queue-window-event - top - (lambda () (send top on-menu-command menu-item)))))) + (cond + [popup-box + (set-box! popup-box menu-item)] + [(parent . is-a? . menu%) + (send parent item-selected menu-item)] + [else + (let ([top (get-top-parent)]) + (when top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))))])) (define parent #f) (define/public (set-parent p) (set! parent p)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index cde3f9e5..5a470bf6 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -40,10 +40,10 @@ (define-objc-mixin (KeyMouseResponder Superclass) [wx] [-a _void (mouseDown: [_id event]) - (unless (do-mouse-event wx event 'left-down #t #f #f) + (unless (do-mouse-event wx event 'left-down #t #f #f 'right-down) (super-tell #:type _void mouseDown: event))] [-a _void (mouseUp: [_id event]) - (unless (do-mouse-event wx event 'left-up #f #f #f) + (unless (do-mouse-event wx event 'left-up #f #f #f 'right-up) (super-tell #:type _void mouseUp: event))] [-a _void (mouseDragged: [_id event]) (unless (do-mouse-event wx event 'motion #t #f #f) @@ -112,20 +112,20 @@ (lambda () (send wx dispatch-on-char k #t)) #t)))))) -(define (do-mouse-event wx event kind l? m? r?) +(define (do-mouse-event wx event kind l? m? r? [ctl-kind kind]) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)]) - (let-values ([(x y) (send wx window-point-to-view pos)]) + (let-values ([(x y) (send wx window-point-to-view pos)] + [(control-down) (bit? modifiers NSControlKeyMask)]) (let ([m (new mouse-event% - [event-type kind] - [left-down l?] + [event-type (if control-down ctl-kind kind)] + [left-down (and l? (not control-down))] [middle-down m?] - [right-down r?] + [right-down (or r? (and l? control-down))] [x (->long x)] [y (->long y)] [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] [meta-down (bit? modifiers NSCommandKeyMask)] [alt-down (bit? modifiers NSAlternateKeyMask)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] @@ -312,7 +312,12 @@ (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) - (def/public-unimplemented popup-menu) + + (define/public (popup-menu m x y) + (send m do-popup (get-cocoa-content) x (flip-client y) + (lambda (thunk) + (queue-window-event this thunk)))) + (define/public (center a b) (void)) (def/public-unimplemented refresh) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index 793c18de..36ff6e78 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -91,7 +91,8 @@ (init-properties [[(symbol-in button check-box choice list-box list-box-dclick text-field text-field-enter slider radio-box - menu-popdown menu-popdown-none tab-panel) + menu-popdown menu-popdown-none tab-panel + menu) event-type] ;; FIXME: should have no default 'button]) @@ -99,7 +100,8 @@ (super-new [time-stamp time-stamp])) (defclass popup-event% control-event% - (properties [[any? menu-id] 0])) + (properties [[any? menu-id] 0]) + (super-new)) (defclass scroll-event% event% (init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type] diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8e3c0ecb..23a4cec8 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -27,6 +27,9 @@ (define-gtk gtk_window_maximize (_fun _GtkWidget -> _void)) (define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void)) +(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) + -> _void + -> (values x y))) (define (handle-delete gtk) (let ([wx (gtk->wx gtk)]) @@ -162,7 +165,9 @@ (pre-on-char w e)) (define/override (client-to-screen x y) - (void)) + (let-values ([(dx dy) (gtk_window_get_position gtk)]) + (set-box! x (+ (unbox x) dx)) + (set-box! y (+ (unbox y) dy)))) (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 9335040e..6b6a0c63 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -7,7 +7,8 @@ "types.rkt" "const.rkt" "utils.rkt" - "menu-bar.rkt") + "menu-bar.rkt" + "../common/event.rkt") (unsafe!) (provide menu%) @@ -22,6 +23,14 @@ (define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_menu_item_set_label (_fun _GtkWidget _string -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-gtk gtk_get_current_event_time (_fun -> _uint32)) +(define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer + (_fun _GtkWidget _pointer _pointer _pointer -> _void) + _pointer _uint _uint32 + -> _void)) (define-signal-handler connect-menu-item-activate "activate" (_fun _GtkWidget -> _void) @@ -29,6 +38,12 @@ (let ([wx (gtk->wx gtk)]) (send wx do-on-select)))) +(define-signal-handler connect-menu-deactivate "deactivate" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx do-no-selected)))) + (define menu-item-handler% (class widget% (init gtk) @@ -41,11 +56,7 @@ (define/public (get-item) menu-item) (define/public (do-on-select) - (let ([top (send menu get-top-parent)]) - (when top - (queue-window-event - top - (lambda () (send top on-menu-command menu-item)))))) + (send menu do-selected menu-item)) (define/public (on-select) (send menu on-select-item menu-item)))) @@ -55,11 +66,15 @@ callback font) + (define cb callback) + (define gtk (gtk_menu_new)) (define/public (get-gtk) gtk) (super-new [gtk gtk]) + (connect-menu-deactivate gtk) + (define items null) (define parent #f) @@ -72,6 +87,56 @@ (send parent get-top-parent) (send parent get-top-window)))) + (define on-popup #f) + (define cancel-none-box (box #t)) + + (define/public (popup x y queue-cb) + (set! on-popup queue-cb) + (set! cancel-none-box (box #f)) + (gtk_menu_popup gtk + #f + #f + (lambda (menu _x _y _push) + (ptr-set! _x _int x) + (ptr-set! _y _int y) + (ptr-set! _push _gboolean #t)) + #f + 0 + (gtk_get_current_event_time))) + + (define/public (do-selected menu-item) + ;; Called in event-pump thread + (let ([top (get-top-parent)]) + (cond + [top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))] + [on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (set! on-popup #f) + (set-box! cancel-none-box #t) + (send e set-menu-id menu-item) + (pu (lambda () (cb this e))))] + [parent (send parent do-selected menu-item)]))) + + (define/public (do-no-selected) + ;; Queue a none-selected event, but only tentatively, because + ;; the selection event may come later and cancel the none-selected + ;; event. + (when on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (send e set-menu-id #f) + (pu (lambda () + (when (eq? on-popup pu) + (set! on-popup #f)) + (unless (unbox cnb) + (cb this e))))))) + (define/private (adjust-shortcut item-gtk title) (cond [(regexp-match #rx"\tCtrl[+](.)$" title) @@ -124,7 +189,8 @@ (define/public (set-label item str) (let ([gtk (find-gtk item)]) (when gtk - (gtk_menu_item_set_label gtk str)))) + (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk) + (fixup-mneumonic str))))) (define/public (enable item on?) (let ([gtk (find-gtk item)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 7e9f50be..eb5e3ce3 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -153,27 +153,37 @@ (GdkEventCrossing-state event) (GdkEventButton-state event)))] [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [type (cond + [(= type GDK_MOTION_NOTIFY) + 'motion] + [(= type GDK_ENTER_NOTIFY) + 'enter] + [(= type GDK_LEAVE_NOTIFY) + 'leave] + [(= type GDK_BUTTON_PRESS) + (case (GdkEventButton-button event) + [(1) 'left-down] + [(3) 'right-down] + [else 'middle-down])] + [else + (case (GdkEventButton-button event) + [(1) 'left-up] + [(3) 'right-up] + [else 'middle-up])])] [m (new mouse-event% - [event-type (cond - [(= type GDK_MOTION_NOTIFY) - 'motion] - [(= type GDK_ENTER_NOTIFY) - 'enter] - [(= type GDK_LEAVE_NOTIFY) - 'leave] - [(= type GDK_BUTTON_PRESS) - (case (GdkEventButton-button event) - [(1) 'left-down] - [(3) 'right-down] - [else 'middle-down])] - [else - (case (GdkEventButton-button event) - [(1) 'left-up] - [(3) 'right-up] - [else 'middle-up])])] - [left-down (bit? modifiers GDK_BUTTON1_MASK)] - [middle-down (bit? modifiers GDK_BUTTON2_MASK)] - [right-down (bit? modifiers GDK_BUTTON2_MASK)] + [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)) @@ -338,7 +348,14 @@ (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) - (def/public-unimplemented popup-menu) + + (define/public (popup-menu m x y) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) + (lambda (thunk) (queue-window-event this thunk))))) + (define/public (center a b) (void)) (define/public (refresh) (void)) @@ -349,7 +366,7 @@ (set-box! x (- (unbox x) (unbox xb))) (set-box! y (- (unbox y) (unbox yb))))) (define/public (client-to-screen x y) - (send parent screen-to-client x y) + (send parent client-to-screen x y) (set-box! x (+ (unbox x) save-x)) (set-box! y (+ (unbox y) save-y))) From 7a4aa05ba138f4ab86161777eec2a09dfe89fe52 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 10:45:34 -0500 Subject: [PATCH 107/462] fix Gtk global<->local original commit: 7de0f66b974dbc926c218cf609ad208a8de1b3f8 --- collects/mred/private/wx/gtk/canvas.rkt | 5 +++++ collects/mred/private/wx/gtk/client-window.rkt | 11 ++++++++++- collects/mred/private/wx/gtk/frame.rkt | 17 +++++++++++++---- collects/mred/private/wx/gtk/window.rkt | 10 +++++++--- 4 files changed, 35 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 738ccbb6..67617318 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -171,6 +171,11 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events?) #t) + ;; For the moment, the client area always starts at the + ;; control area's top left + (define/override (get-client-delta) + (values 0 0)) + ;; Avoid multiple queued paints: (define paint-queued? #f) ;; To handle paint requests that happen while on-paint diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 60cb0d38..5a5e50b7 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -18,6 +18,8 @@ (lambda (gtk a) (let ([wx (gtk->wx gtk)]) (send wx remember-client-size + (GtkAllocation-x a) + (GtkAllocation-y a) (GtkAllocation-width a) (GtkAllocation-height a))) #t)) @@ -30,11 +32,15 @@ (define client-w 0) (define client-h 0) + (define client-x 0) + (define client-y 0) (define/public (on-client-size w h) (void)) - (define/public (remember-client-size w h) + (define/public (remember-client-size x y w h) ;; Called in the Gtk event-loop thread + (set! client-x x) + (set! client-y y) (set! client-w w) (set! client-h h) (queue-window-event this (lambda () @@ -48,4 +54,7 @@ (set-box! xb client-w) (set-box! yb client-h)) + (define/override (get-client-delta) + (values client-x client-y)) + (super-new))) \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 23a4cec8..e4067326 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -16,6 +16,10 @@ ;; ---------------------------------------- +(define GDK_GRAVITY_NORTH_WEST 1) +(define GDK_GRAVITY_STATIC 10) + + (define-gtk gtk_window_new (_fun _int -> _GtkWidget)) (define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) (define-gtk gtk_fixed_new (_fun _gboolean _int -> _GtkWidget)) @@ -30,6 +34,7 @@ (define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) -> _void -> (values x y))) +(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) (define (handle-delete gtk) (let ([wx (gtk->wx gtk)]) @@ -74,7 +79,8 @@ (init [is-dialog? #f]) (inherit get-gtk set-size on-size - pre-on-char pre-on-event) + pre-on-char pre-on-event + get-client-delta) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -165,9 +171,12 @@ (pre-on-char w e)) (define/override (client-to-screen x y) - (let-values ([(dx dy) (gtk_window_get_position gtk)]) - (set-box! x (+ (unbox x) dx)) - (set-box! y (+ (unbox y) dy)))) + (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC) + (let-values ([(dx dy) (gtk_window_get_position gtk)] + [(cdx cdy) (get-client-delta)]) + (gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST) + (set-box! x (+ (unbox x) dx cdx)) + (set-box! y (+ (unbox y) dy cdy)))) (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index eb5e3ce3..edb83cab 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -366,9 +366,13 @@ (set-box! x (- (unbox x) (unbox xb))) (set-box! y (- (unbox y) (unbox yb))))) (define/public (client-to-screen x y) - (send parent client-to-screen x y) - (set-box! x (+ (unbox x) save-x)) - (set-box! y (+ (unbox y) save-y))) + (let-values ([(dx dy) (get-client-delta)]) + (send parent client-to-screen x y) + (set-box! x (+ (unbox x) save-x dx)) + (set-box! y (+ (unbox y) save-y dy)))) + + (define/public (get-client-delta) + (values 0 0)) (def/public-unimplemented get-position) (def/public-unimplemented fit) From 07597c6b53483cbd09b85c93d9a81bc910f01238 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 12:04:15 -0500 Subject: [PATCH 108/462] radio-box and transparent canvas repairs original commit: 4628ab4db859a0d421428bb602ec5e74de9eddfa --- collects/mred/private/wx/cocoa/canvas.rkt | 4 +++- collects/mred/private/wx/cocoa/radio-box.rkt | 11 +++++++++-- collects/mred/private/wx/gtk/canvas.rkt | 6 +++++- collects/mred/private/wx/gtk/radio-box.rkt | 17 +++++++++++------ 4 files changed, 28 insertions(+), 10 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index b18587ed..ccfed82f 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -331,7 +331,9 @@ 1)])) (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) bg-col) + (define/public (get-canvas-background) (if (memq 'transparent canvas-style) + #f + bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) (if now-drawing? diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 464259ad..cb082d63 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -21,6 +21,7 @@ (import-class NSMatrix NSButtonCell) (define NSRadioModeMatrix 0) +(define NSListModeMatrix 2) (define-objc-class MyMatrix NSMatrix #:mixins (FocusResponder) @@ -115,8 +116,14 @@ (set-focus))) (define/public (set-selection i) - (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) - column: #:type _NSInteger (if horiz? i 0))) + (if (= i -1) + (begin + ;; Need to change to NSListModeMatrix to disable all. + ;; It seem that we don't have to change the mode back, for some reason. + (tellv (get-cocoa) setMode: #:type _int NSListModeMatrix) + (tellv (get-cocoa) deselectAllCells)) + (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0)))) (define/public (get-selection) (if horiz? (tell #:type _NSInteger (get-cocoa) selectedColumn) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 67617318..80b47b33 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -267,9 +267,13 @@ (define clear-bg? (and (not (memq 'transparent style)) (not (memq 'no-autoclear style)))) + (define transparent? + (memq 'transparent style)) (define gc #f) (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) bg-col) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) (if now-drawing? diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 30952d0c..c56091c7 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -8,6 +8,7 @@ "widget.rkt" "window.rkt" "pixbuf.rkt" + "message.rkt" "../common/event.rkt" "../../lock.rkt") (unsafe!) @@ -18,7 +19,7 @@ (define _GSList (_cpointer/null 'GSList)) -(define-gtk gtk_radio_button_new_with_label (_fun _GSList _string -> _GtkWidget)) +(define-gtk gtk_radio_button_new_with_mnemonic (_fun _GSList _string -> _GtkWidget)) (define-gtk gtk_radio_button_new (_fun _GSList -> _GtkWidget)) (define-gtk gtk_radio_button_get_group (_fun _GtkWidget -> _GSList)) (define-gtk gtk_radio_button_set_group (_fun _GtkWidget _GSList -> _void)) @@ -46,7 +47,7 @@ (define radio-gtks (for/list ([lbl (in-list labels)]) (let ([radio-gtk (cond [(string? lbl) - (gtk_radio_button_new_with_label #f lbl)] + (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] [(send lbl ok?) (let ([radio-gtk (gtk_radio_button_new #f)] [image-gtk (gtk_image_new_from_pixbuf @@ -55,13 +56,15 @@ (gtk_widget_show image-gtk) radio-gtk)] [else - (gtk_radio_button_new_with_label #f "")])]) + (gtk_radio_button_new_with_mnemonic #f "")])]) (gtk_box_pack_start gtk radio-gtk #t #t 0) (gtk_widget_show radio-gtk) radio-gtk))) (for ([radio-gtk (in-list (cdr radio-gtks))]) (let ([g (gtk_radio_button_get_group (car radio-gtks))]) (gtk_radio_button_set_group radio-gtk g))) + + (define dummy-gtk #f) (super-new [parent parent] [gtk gtk] @@ -101,9 +104,11 @@ (lambda () (set! no-clicked? #t) (if (= i -1) - (let ([i (get-selection)]) - (unless (= i -1) - (gtk_toggle_button_set_active (list-ref radio-gtks i) #f))) + (when (pair? radio-gtks) + (unless dummy-gtk + (set! dummy-gtk (gtk_radio_button_new + (gtk_radio_button_get_group (car radio-gtks))))) + (gtk_toggle_button_set_active dummy-gtk #t)) (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) (set! no-clicked? #f)))) From 668c68837fe3e56c974ecba43c99640480501dcc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Jul 2010 12:31:11 -0500 Subject: [PATCH 109/462] fix gtk callback on first radio button in a box original commit: 1c4b543fb529092fbf8a680996250bbfe52effdb --- collects/mred/private/wx/gtk/radio-box.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index c56091c7..dc91cd37 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -73,9 +73,8 @@ [no-show? (memq 'deleted style)]) (set-auto-size) - (for ([radio-gtk (in-list (cdr radio-gtks))]) - (connect-clicked radio-gtk)) (for ([radio-gtk (in-list radio-gtks)]) + (connect-clicked radio-gtk) (connect-key-and-mouse radio-gtk) (connect-focus radio-gtk)) From 8f4252881b22e892fc790b573e76359138b9c3f5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 08:43:38 -0600 Subject: [PATCH 110/462] fix mouse-moved events for cocoa original commit: c244a6106a10f16da5d7fc8b5d29655281647d78 --- collects/mred/private/wx/cocoa/window.rkt | 13 ++++++++++ collects/mred/private/wx/common/freeze.rkt | 28 ++++++++++++++++++++-- 2 files changed, 39 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5a470bf6..06a6491f 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -49,6 +49,19 @@ (unless (do-mouse-event wx event 'motion #t #f #f) (super-tell #:type _void mouseDragged: event))] [-a _void (mouseMoved: [_id event]) + ;; This event is sent to the first responder, instead of the + ;; view under the mouse. + (let* ([win (tell event window)] + [view (and win (tell win contentView))] + [hit (and view (tell view hitTest: #:type _NSPoint + (tell #:type _NSPoint event locationInWindow)))]) + (let loop ([hit hit]) + (when hit + (if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:)) + (tell hit doMouseMoved: event) + (loop (tell hit superview))))))] + [-a _void (doMouseMoved: [_id event]) + ;; called by mouseMoved: (unless (do-mouse-event wx event 'motion #f #f #f) (super-tell #:type _void mouseMoved: event))] [-a _void (mouseEntered: [_id event]) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index d5dc26d0..11a8278d 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -36,6 +36,30 @@ freeze-tag))))) (void)))) +(define (internal-error str) + (log-error + (apply string-append + (format "internal error: ~s" str) + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)])))))) + ;; FIXME: waiting 200msec is not a good enough rule. (define (constrained-reply es thunk default [should-give-up? (let ([now (current-inexact-milliseconds)]) @@ -43,7 +67,7 @@ ((current-inexact-milliseconds) . > . (+ now 200))))]) (let ([b (freezer-box)]) (unless b - (log-error "internal error: constrained-reply not within an unfreeze point")) + (internal-error "constrained-reply not within an unfreeze point")) (if (eq? (current-thread) (eventspace-handler-thread es)) (if (pair? b) ;; already suspended, so push this work completely: @@ -79,5 +103,5 @@ (scheme_restore_on_atomic_timeout prev)))) freeze-tag)))))) (begin - (log-error "internal error: wrong eventspace for constrained event handling\n") + (internal-error "wrong eventspace for constrained event handling\n") default)))) From b9ca725b7d9a5866cac27fb8e5d6878a321027fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 09:36:01 -0600 Subject: [PATCH 111/462] fix gtk canvas reset original commit: b027bc3bc3b3f45e8c0965498b93b601d25e0ca4 --- collects/mred/private/wx/gtk/canvas.rkt | 4 ++-- collects/mred/private/wx/gtk/dc.rkt | 16 +++++++--------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 80b47b33..56df00e9 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -204,12 +204,12 @@ (gtk_widget_queue_draw client-gtk)) (define/public (reset-child-dcs) - (send dc reset-dc #t)) + (send dc reset-dc)) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?)) (define/override (internal-on-client-size w h) - (send dc reset-dc #f)) + (send dc reset-dc)) (define/override (on-client-size w h) (let ([xb (box 0)] [yb (box 0)]) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index f957b182..20e53029 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -31,15 +31,13 @@ (set! c (gdk_cairo_create w)) c)))) - (define/public (reset-dc force?) - (when (or force? - (eq? 'windows (system-type))) - ;; FIXME: ensure that the dc is not in use - (as-entry - (lambda () - (when c - (cairo_destroy c) - (set! c #f)))))) + (define/public (reset-dc) + ;; FIXME: ensure that the dc is not in use + (as-entry + (lambda () + (when c + (cairo_destroy c) + (set! c #f))))) (define/override (get-size) (let-values ([(w h) (get-client-size)]) From 55bbadee9c2a204fb1098e1239fe4e86cf3ca523 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 09:40:39 -0600 Subject: [PATCH 112/462] hidden name message should simply not draw original commit: 6e977d7c20787cad4594df663525d3eb4310231f --- collects/mrlib/name-message.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index cdb5fbdb..488fa9b2 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -185,6 +185,7 @@ (let-values ([(w h) (get-client-size)]) (cond [hidden? + #; (let ([pen (send dc get-pen)] [brush (send dc get-brush)]) (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) From 1d62d8420ec5c72f026b8de6be52a8d532918b67 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 16:56:58 -0600 Subject: [PATCH 113/462] windows fixes original commit: e0bbe944aa92584880fb20fc485d0d0e93f1c2c1 --- collects/mred/private/wx/cocoa/dc.rkt | 2 +- collects/mred/private/wx/gtk/canvas.rkt | 5 +++-- collects/mred/private/wx/gtk/dc.rkt | 21 ++++++++++++++++++--- collects/mred/private/wx/gtk/frame.rkt | 5 +++++ collects/mred/private/wx/gtk/menu-bar.rkt | 11 +++++++++-- collects/mred/private/wx/gtk/window.rkt | 2 ++ 6 files changed, 38 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 9f586383..ddc01161 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -69,7 +69,7 @@ (CGContextScaleCTM cg 1 -1) (CGContextTranslateCTM cg (- old-dx) (- old-dy)) (set-bounds dx dy width height) - (reset-cr)) + (reset-cr cr)) (def/override (get-size) (values (exact->inexact clip-width) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 56df00e9..2cd0c3c5 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -85,7 +85,7 @@ [gl-config #f]) (inherit get-gtk set-size get-size get-client-size - on-size register-as-child) + on-size register-as-child get-top-win) (define client-gtk (gtk_drawing_area_new)) (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) @@ -134,7 +134,8 @@ (let ([w (box 0)] [h (box 0)]) (get-client-size w h) - (values (unbox w) (unbox h))))])) + (values (unbox w) (unbox h))))] + [window-lock (send (get-top-win) get-dc-lock)])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 20e53029..a421218e 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -20,7 +20,9 @@ (define dc-backend% (class default-dc-backend% (init-field gtk - get-client-size) + get-client-size + window-lock) + (inherit reset-cr) (define c #f) @@ -28,8 +30,21 @@ (or c (let ([w (g_object_get_window gtk)]) (and w - (set! c (gdk_cairo_create w)) - c)))) + (begin + ;; Under Windows, creating a Cairo context within + ;; a frame inteferes with any other Cairo context + ;; within the same frame. So we use a lock to + ;; serialize drawing to different contexts. + (when window-lock (semaphore-wait window-lock)) + (set! c (gdk_cairo_create w)) + (reset-cr c) + c))))) + + (define/override (release-cr cr) + (when window-lock + (cairo_destroy c) + (set! c #f) + (semaphore-post window-lock))) (define/public (reset-dc) ;; FIXME: ensure that the dc is not in use diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index e4067326..2c6b2ac5 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -124,6 +124,11 @@ (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) (void)) + (define/override (get-top-win) this) + + (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) + (define/public (get-dc-lock) dc-lock) + (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 84abe61c..52dfe4e5 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -18,6 +18,8 @@ (define-gtk gtk_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) (define (fixup-mneumonic title) (regexp-replace* @@ -56,7 +58,12 @@ (define/public (get-top-window) top-wx) - (def/public-unimplemented set-label-top) + (define/public (set-label-top pos str) + (let ([l (list-ref menus pos)]) + (let ([item-gtk (car l)]) + (gtk_label_set_text_with_mnemonic (gtk_bin_get_child item-gtk) + (fixup-mneumonic str))))) + (def/public-unimplemented number) (def/public-unimplemented enable-top) @@ -77,7 +84,7 @@ (define (append-menu menu title) (send menu set-parent this) (let ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]) - (set! menus (append menus (list (list item menu title)))) + (set! menus (append menus (list (list item menu)))) (let ([gtk (send menu get-gtk)]) (g_object_ref gtk) (gtk_menu_item_set_submenu item gtk)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index edb83cab..d52a0dd4 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -285,6 +285,8 @@ (define/public (get-parent) parent) + (define/public (get-top-win) (send parent get-top-win)) + (define/public (get-size xb yb) (set-box! xb save-w) (set-box! yb save-h)) From a95c0b901c1b1182dc70327a3d60c00cb835f89c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 18:45:39 -0600 Subject: [PATCH 114/462] fix alpha plus draw-bitmap original commit: 86f0db41bcfef0dc68b7dd47dcc3ad8cd9000801 --- collects/mred/private/wx/common/freeze.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 11a8278d..b2a4dce6 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -3,7 +3,7 @@ racket/draw/hold "utils.rkt" "queue.rkt" - "../../lock.rkt") + ffi/unsafe/atomic) (unsafe!) (provide call-as-unfreeze-point @@ -25,7 +25,7 @@ (let ([b (box null)]) (parameterize ([freezer-box b]) ;; In atomic mode: - (as-entry (lambda () (thunk))) + (call-as-atomic (lambda () (thunk))) ;; Out of atomic mode: (let ([l (unbox b)]) (for ([k (in-list (reverse l))]) @@ -69,7 +69,7 @@ (unless b (internal-error "constrained-reply not within an unfreeze point")) (if (eq? (current-thread) (eventspace-handler-thread es)) - (if (pair? b) + (if (pair? (unbox b)) ;; already suspended, so push this work completely: (set-box! b (cons thunk (unbox b))) ;; try to do some work: @@ -79,7 +79,7 @@ (when (and ready? (should-give-up?)) (scheme_call_with_composable_no_dws (lambda (proc) - (set-box! (freezer-box) (cons proc (freezer-box))) + (set-box! b (cons proc (unbox b))) (scheme_restore_on_atomic_timeout prev) (scheme_abort_continuation_no_dws freeze-tag From cba60dd8a7dedbad7db4e1a7ca3dc5bfb4532e0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 18:47:57 -0600 Subject: [PATCH 115/462] cocoa slider initial value original commit: 1beecc143d9e6c2c4bc42491bfc943850eac9618 --- collects/mred/private/wx/cocoa/slider.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 45c03b5b..679f42bd 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -45,6 +45,7 @@ [vert? (memq 'vertical style)]) (tellv cocoa setMinValue: #:type _double* lo) (tellv cocoa setMaxValue: #:type _double* hi) + (tellv cocoa setDoubleValue: #:type _double* val) (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) (tellv cocoa setFrame: #:type _NSRect (make-NSRect From 317bf373fd210035897cee90c23e4193fc4af948 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Jul 2010 07:51:14 -0600 Subject: [PATCH 116/462] misc repairs original commit: 626ceef11b1280486c4788198fba2ef54389a073 --- collects/mred/private/mrpanel.rkt | 4 +- collects/mred/private/wx/cocoa/frame.rkt | 3 +- collects/mred/private/wx/common/freeze.rkt | 122 ++++++++++--------- collects/mred/private/wx/gtk/canvas.rkt | 7 +- collects/mred/private/wx/gtk/group-panel.rkt | 11 +- collects/mred/private/wx/gtk/panel.rkt | 5 +- collects/mred/private/wx/gtk/radio-box.rkt | 4 +- collects/mred/private/wx/gtk/tab-panel.rkt | 1 - collects/mred/private/wx/gtk/widget.rkt | 2 + collects/tests/gracket/item.rkt | 2 +- 10 files changed, 90 insertions(+), 71 deletions(-) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 34c494af..4c42d08c 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -10,9 +10,7 @@ "kw.ss" "wxpanel.ss" "mrwindow.ss" - "mrcontainer.ss" - "mrtabgroup.ss" - "mrgroupbox.ss") + "mrcontainer.ss") (provide pane% vertical-pane% diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 202e45fb..190766c2 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -95,7 +95,8 @@ (tell (tell MyWindow alloc) initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) (make-NSRect (make-NSPoint x y) - (make-NSSize w h))) + (make-NSSize (max 30 w) + (max 0 h)))) styleMask: #:type _int (if (memq 'no-caption style) NSBorderlessWindowMask (bitwise-ior diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index b2a4dce6..0d1a7965 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -39,26 +39,28 @@ (define (internal-error str) (log-error (apply string-append - (format "internal error: ~s" str) - (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) - (let ([name (car c)] - [loc (cdr c)]) - (cond - [loc - (string-append - "\n" - (cond - [(srcloc-line loc) - (format "~a:~a:~a" - (srcloc-source loc) - (srcloc-line loc) - (srcloc-column loc))] - [else - (format "~a::~a" - (srcloc-source loc) - (srcloc-position loc))]) - (if name (format " ~a" name) ""))] - [else (format "\n ~a" name)])))))) + (format "internal error: ~a" str) + (append + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)]))) + '("\n"))))) ;; FIXME: waiting 200msec is not a good enough rule. (define (constrained-reply es thunk default [should-give-up? @@ -66,42 +68,46 @@ (lambda () ((current-inexact-milliseconds) . > . (+ now 200))))]) (let ([b (freezer-box)]) - (unless b - (internal-error "constrained-reply not within an unfreeze point")) - (if (eq? (current-thread) (eventspace-handler-thread es)) - (if (pair? (unbox b)) - ;; already suspended, so push this work completely: - (set-box! b (cons thunk (unbox b))) - ;; try to do some work: - (let* ([prev #f] - [ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) - (scheme_call_with_composable_no_dws - (lambda (proc) - (set-box! b (cons proc (unbox b))) - (scheme_restore_on_atomic_timeout prev) - (scheme_abort_continuation_no_dws - freeze-tag - (lambda () default))) - freeze-tag) - (void)))]) - (with-holding - handler - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt ; for composable continuation + (cond + [(not b) + (internal-error (format "constrained-reply not within an unfreeze point for ~s" + thunk)) + default] + [(not (eq? (current-thread) (eventspace-handler-thread es))) + (internal-error "wrong eventspace for constrained event handling\n") + default] + [(pair? (unbox b)) + ;; already suspended, so push this work completely: + (set-box! b (cons thunk (unbox b))) + default] + [else + ;; try to do some work: + (let* ([prev #f] + [ready? #f] + [handler (lambda () + (when (and ready? (should-give-up?)) + (scheme_call_with_composable_no_dws + (lambda (proc) + (set-box! b (cons proc (unbox b))) + (scheme_restore_on_atomic_timeout prev) + (scheme_abort_continuation_no_dws + freeze-tag + (lambda () default))) + freeze-tag) + (void)))]) + (with-holding + handler + (call-with-continuation-prompt ; to catch aborts + (lambda () + (call-with-continuation-prompt ; for composable continuation + (lambda () + (set! prev (scheme_set_on_atomic_timeout handler)) + (set! ready? #t) + (dynamic-wind + void (lambda () - (set! prev (scheme_set_on_atomic_timeout handler)) - (set! ready? #t) - (dynamic-wind - void - (lambda () - (parameterize ([freezer-box #f]) - (thunk))) - (lambda () - (scheme_restore_on_atomic_timeout prev)))) - freeze-tag)))))) - (begin - (internal-error "wrong eventspace for constrained event handling\n") - default)))) + (parameterize ([freezer-box #f]) + (thunk))) + (lambda () + (scheme_restore_on_atomic_timeout prev)))) + freeze-tag)))))]))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 2cd0c3c5..4ee321b1 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -22,7 +22,6 @@ (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) -(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) @@ -205,9 +204,11 @@ (gtk_widget_queue_draw client-gtk)) (define/public (reset-child-dcs) - (send dc reset-dc)) + (when (dc . is-a? . dc%) + (send dc reset-dc))) (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) + (register-as-child parent on?) + (when on? (reset-child-dcs))) (define/override (internal-on-client-size w h) (send dc reset-dc)) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index b22859db..2550a2c0 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -25,7 +25,7 @@ style label) - (inherit set-size set-auto-size get-gtk) + (inherit set-size set-auto-size get-gtk get-height) (define gtk (gtk_frame_new label)) (define client-gtk (gtk_fixed_new)) @@ -40,6 +40,15 @@ (set-auto-size) + ;; The delta between the group box height and its + ;; client height can go bad if the label is set. + ;; Avoid the problem by effectively using the + ;; original delta. + (define orig-h (get-height)) + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (set-box! yb (- (get-height) orig-h))) + (define/public (set-label s) (gtk_frame_set_label gtk s)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 5cee2fcc..0fd06faa 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -37,8 +37,9 @@ (reset-child-dcs)) (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - + (register-as-child parent on?) + (when on? (reset-child-dcs))) + (define/override (register-child child on?) (let ([now-on? (and (memq child children) #t)]) (unless (eq? on? now-on?) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index dc91cd37..d113b269 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -43,7 +43,9 @@ (inherit set-auto-size on-set-focus) - (define gtk (gtk_vbox_new #f 0)) + (define gtk (if (memq 'horizontal style) + (gtk_hbox_new #f 0) + (gtk_vbox_new #f 0))) (define radio-gtks (for/list ([lbl (in-list labels)]) (let ([radio-gtk (cond [(string? lbl) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index a190e4c4..5ff4a204 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -16,7 +16,6 @@ (define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) -(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index cc3cf704..bb1d602b 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -14,6 +14,7 @@ gtk_widget_hide gtk_vbox_new + gtk_hbox_new gtk_box_pack_start gtk_box_pack_end) @@ -21,6 +22,7 @@ (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 40be32ba..225394a2 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2214,7 +2214,7 @@ (let loop ([l radios]) (let* ([c (car l)] [rest (cdr l)] - [n (send c number)] + [n (send c get-number)] [v (send c get-selection)]) (if (< v (sub1 n)) (send c set-selection (add1 v)) From 543525dc0bad1851d0abe57dc97307fffe205ae1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Jul 2010 13:04:39 -0600 Subject: [PATCH 117/462] gtk combo boxes original commit: 37d4cfb14863683e6501a1ba975a933aae3847ba --- collects/mred/private/mrtextfield.rkt | 30 ++--- collects/mred/private/wx/cocoa/canvas.rkt | 3 + collects/mred/private/wx/gtk/canvas.rkt | 127 ++++++++++++++++------ collects/mred/private/wx/gtk/dc.rkt | 7 +- collects/mred/private/wx/gtk/types.rkt | 3 + collects/mred/private/wx/gtk/utils.rkt | 4 + collects/mred/private/wxtextfield.rkt | 14 ++- 7 files changed, 136 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index e76c938c..400acb46 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -110,15 +110,20 @@ [get-menu (lambda () menu)] [append (lambda (item) (check-label-string '(method combo-field% append) item) - (make-object menu-item% item menu - (lambda (i e) - (focus) - (set-value item) - (let ([e (get-editor)]) - (send e set-position 0 (send e last-position))) - (send (as-entry (lambda () (mred->wx this))) - command - (make-object wx:control-event% 'text-field)))))]) + (unless (send (mred->wx this) append-combo-item item + (lambda () (handle-selected item))) + (make-object menu-item% item menu + (lambda (i e) + (handle-selected item)))))]) + (private + [handle-selected (lambda (item) + (focus) + (set-value item) + (let ([e (get-editor)]) + (send e set-position 0 (send e last-position))) + (send (as-entry (lambda () (mred->wx this))) + command + (make-object wx:control-event% 'text-field)))]) (override [on-subwindow-event (lambda (w e) (and (send e button-down?) @@ -130,7 +135,6 @@ (private-field [menu (new popup-menu% [font font])]) (sequence - (for-each (lambda (item) - (append item)) - choices) - (super-init label parent callback init-value (list* combo-flag 'single style)))))) + (super-init label parent callback init-value (list* combo-flag 'single style)) + (for-each (lambda (item) (append item)) + choices))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index ccfed82f..644cb8bf 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -330,6 +330,9 @@ (scroller-page scroller) 1)])) + (define/public (append-combo-item str) #f) + (define/public (on-combo-select i) (void)) + (define bg-col (make-object color% "white")) (define/public (get-canvas-background) (if (memq 'transparent canvas-style) #f diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 4ee321b1..ebed2371 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -20,6 +20,9 @@ (define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) + (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) @@ -37,6 +40,12 @@ (define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)) (define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) + #:c-id g_object_set) + (define-cstruct _GdkColor ([pixel _uint32] [red _uint16] [green _uint16] @@ -49,9 +58,30 @@ (define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) (define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) +;; We rely some on the implementation of GtkComboBoxEntry to replace +;; the drawing routine. +(define-cstruct _GList ([data _pointer])) +(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null)) +(define-gdk gdk_window_hide (_fun _pointer -> _void)) +(define (get-subwindow gtk) + (let* ([win (g_object_get_window gtk)] + [subs (gdk_window_get_children win)]) + (if subs + (GList-data subs) + win))) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx combo-maybe-clicked)))) + +(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) + (define (handle-expose gtk event) (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) + (let ([gc (send wx get-canvas-background-for-clearing)]) (when gc (gdk_draw_rectangle (g_object_get_window gtk) gc #t 0 0 32000 32000))) @@ -74,6 +104,7 @@ (define handle_value_changed_v (function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void))) +(define-gtk gtk_entry_get_type (_fun -> _GType)) (define canvas% (class (client-size-mixin window%) @@ -86,36 +117,45 @@ (inherit get-gtk set-size get-size get-client-size on-size register-as-child get-top-win) - (define client-gtk (gtk_drawing_area_new)) - (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) - (if (or (memq 'hscroll style) - (memq 'vscroll style)) - (let ([hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] - [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) - (let ([h (gtk_hbox_new #f 0)] - [v (gtk_vbox_new #f 0)] - [v2 (gtk_vbox_new #f 0)] - [h2 (gtk_vbox_new #f 0)] - [hscroll (gtk_hscrollbar_new hadj)] - [vscroll (gtk_vscrollbar_new vadj)] - [resize-box (gtk_drawing_area_new)]) - (gtk_box_pack_start h v #t #t 0) - (gtk_box_pack_start v client-gtk #t #t 0) - (gtk_box_pack_start h v2 #f #f 0) - (gtk_box_pack_start v2 vscroll #t #t 0) - (gtk_box_pack_start v h2 #f #f 0) - (gtk_box_pack_start h2 hscroll #t #t 0) - (gtk_box_pack_start v2 resize-box #f #f 0) - (gtk_widget_show hscroll) - (gtk_widget_show vscroll) - (gtk_widget_show h) - (gtk_widget_show v) - (gtk_widget_show v2) - (gtk_widget_show h2) - (gtk_widget_show resize-box) - (gtk_widget_show client-gtk) - (values h hadj vadj h2 v2 resize-box))) - (values client-gtk #f #f #f #f #f))) + (define is-combo? (memq 'combo style)) + + (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) + (cond + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (gtk_hbox_new #f 0)] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (gtk_widget_show hscroll) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (gtk_widget_show v2) + (gtk_widget_show h2) + (gtk_widget_show resize-box) + (gtk_widget_show client-gtk) + (values client-gtk h hadj vadj h2 v2 resize-box)))] + [is-combo? + (let* ([gtk (gtk_combo_box_entry_new_text)] + [orig-entry (gtk_bin_get_child gtk)]) + (values orig-entry gtk #f #f #f #f #f))] + [else + (let ([client-gtk (gtk_drawing_area_new)]) + (values client-gtk client-gtk #f #f #f #f #f))])) (super-new [parent parent] [gtk gtk] @@ -123,7 +163,9 @@ [no-show? (memq 'deleted style)] [extra-gtks (if (eq? client-gtk gtk) null - (list client-gtk hscroll-adj vscroll-adj))]) + (if hscroll-adj + (list client-gtk hscroll-adj vscroll-adj) + (list client-gtk)))]) (set-size x y w h) @@ -134,7 +176,11 @@ [h (box 0)]) (get-client-size w h) (values (unbox w) (unbox h))))] - [window-lock (send (get-top-win) get-dc-lock)])) + [window-lock (send (get-top-win) get-dc-lock)] + [get-window (lambda (client-gtk) + (if is-combo? + (get-subwindow client-gtk) + (g_object_get_window client-gtk)))])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) @@ -146,7 +192,7 @@ (GtkRequisition-height r) (GtkRequisition-height r)))) - (g_signal_connect client-gtk "expose_event" handle_expose) + (g_signal_connect client-gtk "expose-event" handle_expose) (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK @@ -294,6 +340,19 @@ gc) #f))) + (when is-combo? + (connect-changed client-gtk)) + + (define/public (append-combo-item str) + (gtk_combo_box_append_text gtk str)) + + (define/public (combo-maybe-clicked) + (let ([i (gtk_combo_box_get_active gtk)]) + (when (i . > . -1) + (gtk_combo_box_set_active gtk -1) + (queue-window-event this (lambda () (on-combo-select i)))))) + (define/public (on-combo-select i) (void)) + (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a421218e..bb31608e 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -21,14 +21,15 @@ (class default-dc-backend% (init-field gtk get-client-size - window-lock) + window-lock + [get-window g_object_get_window]) (inherit reset-cr) (define c #f) (define/override (get-cr) (or c - (let ([w (g_object_get_window gtk)]) + (let ([w (get-window gtk)]) (and w (begin ;; Under Windows, creating a Cairo context within @@ -36,7 +37,7 @@ ;; within the same frame. So we use a lock to ;; serialize drawing to different contexts. (when window-lock (semaphore-wait window-lock)) - (set! c (gdk_cairo_create w)) + (set! c (gdk_cairo_create w)) (reset-cr c) c))))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 49305bcf..20d9797d 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -6,6 +6,7 @@ _GtkWidget _GtkWindow _gpointer _GdkEventExpose + _GType _fnpointer _gboolean @@ -20,6 +21,8 @@ _GdkEventCrossing _GdkEventCrossing-pointer (struct-out GdkEventCrossing)) +(define _GType _long) + (define _GdkWindow (_cpointer/null 'GdkWindow)) (define _GtkWidget (_cpointer 'GtkWidget)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index d3c6946c..a8e27d4a 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -19,6 +19,8 @@ g_object_get_data g_signal_connect + g_object_new + (rename-out [g_object_get g_object_get_window]) get-gtk-object-flags @@ -87,6 +89,8 @@ [w : (_ptr o _GdkWindow)] (_pointer = #f) -> _void -> w)) +(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget)) + ;; This seems dangerous, since the shape of GtkObject is not ;; documented. But it seems to be the only way to get and set ;; flags. diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 629b070c..7c92b581 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -162,7 +162,11 @@ (private-field [l (and label (make-object wx-message% #f proxy p label -1 -1 null font))] - [c (make-object wx-text-editor-canvas% #f proxy this p + [c (make-object (class wx-text-editor-canvas% + (define/override (on-combo-select i) + ((list-ref callbacks (- (length callbacks) i 1)))) + (super-new)) + #f proxy this p (append '(control-border) (if (memq 'combo style) @@ -172,7 +176,13 @@ (if (memq 'hscroll style) null '(hide-hscroll)) - '(hide-vscroll hide-hscroll))))]) + '(hide-vscroll hide-hscroll))))] + [callbacks null]) + (public + [append-combo-item (lambda (s cb) + (and (send c append-combo-item s) + (set! callbacks (cons cb callbacks)) + #t))]) (sequence (send c skip-subwindow-events? #t) (when l From a90cf8f8d5422e99f8139e9e60ca9c455a084e24 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Jul 2010 19:12:54 -0600 Subject: [PATCH 118/462] better frame sizing in gtk (but still not right) original commit: a368362803d93ea54c6b78280c474e37cd25052f --- collects/mred/private/mrtextfield.rkt | 8 -- collects/mred/private/wx/cocoa/canvas.rkt | 107 ++++++++++++++++-- collects/mred/private/wx/cocoa/item.rkt | 8 +- collects/mred/private/wx/cocoa/list-box.rkt | 3 +- collects/mred/private/wx/cocoa/message.rkt | 3 +- collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/radio-box.rkt | 10 +- collects/mred/private/wx/cocoa/window.rkt | 15 +-- collects/mred/private/wx/common/freeze.rkt | 6 +- collects/mred/private/wx/gtk/canvas.rkt | 2 + .../mred/private/wx/gtk/client-window.rkt | 11 +- collects/mred/private/wx/gtk/const.rkt | 10 ++ collects/mred/private/wx/gtk/frame.rkt | 66 ++++++++--- collects/mred/private/wx/gtk/types.rkt | 12 +- collects/mred/private/wx/gtk/window.rkt | 75 +++++++++--- collects/mred/private/wxtextfield.rkt | 9 +- 16 files changed, 277 insertions(+), 70 deletions(-) diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index 400acb46..c3747db1 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -124,14 +124,6 @@ (send (as-entry (lambda () (mred->wx this))) command (make-object wx:control-event% 'text-field)))]) - (override - [on-subwindow-event (lambda (w e) - (and (send e button-down?) - (let-values ([(cw) (send (mred->wx this) get-canvas-width)]) - (and ((send e get-x) . >= . (- cw side-combo-width)) - (begin - (on-popup e) - #t)))))]) (private-field [menu (new popup-menu% [font font])]) (sequence diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 644cb8bf..072401c9 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -11,6 +11,7 @@ "window.rkt" "dc.rkt" "queue.rkt" + "item.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -21,7 +22,9 @@ ;; ---------------------------------------- -(import-class NSView NSGraphicsContext NSScroller) +(import-class NSView NSGraphicsContext NSScroller NSComboBox) + +(import-protocol NSComboBoxDelegate) (define-objc-class MyView NSView #:mixins (FocusResponder KeyMouseResponder) @@ -52,6 +55,38 @@ (-a _void (onVScroll: [_id scroller]) (when wx (send wx do-scroll 'vertical scroller)))) +(define-objc-class MyComboBox NSComboBox + #:mixins (FocusResponder KeyMouseResponder) + #:protocols (NSComboBoxDelegate) + [wx] + (-a _void (drawRect: [_NSRect r]) + (super-tell #:type _void drawRect: #:type _NSRect r) + (unless (send wx during-menu-click?) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState)))) + (send wx queue-paint) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event))) + (-a _void (comboBoxWillPopUp: [_id notification]) + (send wx starting-combo)) + (-a _void (comboBoxWillDismiss: [_id notification]) + (send wx ending-combo)) + (-a _void (viewWillMoveToWindow: [_id w]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc)))))) + (define-struct scroller (cocoa [range #:mutable] [page #:mutable])) (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) @@ -66,7 +101,6 @@ (inherit get-cocoa get-eventspace make-graphics-context - get-client-size is-shown-to-root? move get-x get-y on-size @@ -103,10 +137,13 @@ (set! refresh-after-drawing? #f) (refresh))))))) (define/override (refresh) + ;; can be called from any thread, including the event-pump thread (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) + (define is-combo? (memq 'combo style)) + (super-new [parent parent] [cocoa @@ -118,14 +155,20 @@ (define cocoa (get-cocoa)) - (define content-cocoa - (as-objc-allocation - (tell (tell MyView alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) - (make-NSSize w h))))) + (define content-cocoa + (let ([r (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))]) + (as-objc-allocation + (tell (tell (if is-combo? MyComboBox MyView) alloc) + initWithFrame: #:type _NSRect r)))) (tell #:type _void cocoa addSubview: content-cocoa) (set-ivar! content-cocoa wx this) + (when is-combo? + (tellv content-cocoa setEditable: #:type _BOOL #f) + (tellv content-cocoa setDelegate: content-cocoa) + (install-control-font content-cocoa #f)) + (define dc (make-object dc% (make-graphics-context) 0 0 10 10)) (queue-paint) @@ -139,7 +182,16 @@ [xb (box 0)] [yb (box 0)]) (get-client-size xb yb) - (send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox yb)))) + (send dc reset-bounds + (+ (NSPoint-x p) (if is-combo? 2 0)) + (- (NSPoint-y p) (if is-combo? 22 0)) + (max 1 (- (unbox xb) (if is-combo? 22 0))) + (unbox yb)))) + + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (when is-combo? + (set-box! yb (max 0 (- (unbox yb) 5))))) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?)) @@ -330,7 +382,9 @@ (scroller-page scroller) 1)])) - (define/public (append-combo-item str) #f) + (define/public (append-combo-item str) + (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) + #t) (define/public (on-combo-select i) (void)) (define bg-col (make-object color% "white")) @@ -383,9 +437,40 @@ (void))) (define/public (on-scroll e) (void)) - (define/override (wants-all-events?) + (define/override (definitely-wants-event? e) ;; Called in Cocoa event-handling mode - #t) + (or (not is-combo?) + (e . is-a? . key-event%) + (not (send e button-down? 'left)) + (not (on-menu-click? e)))) + + (define/private (on-menu-click? e) + ;; Called in Cocoa event-handling mode + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + ((send e get-x) . > . (- (unbox xb) 22)))) + + (define/public (starting-combo) + (set! in-menu-click? #t) + (tellv content-cocoa setStringValue: #:type _NSString current-text)) + + (define/public (ending-combo) + (set! in-menu-click? #f) + (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) + (when (pos . > . -1) + (queue-window-event this (lambda () (on-combo-select pos))))) + (refresh)) + + (define current-text "") + (define/public (set-combo-text t) + (set! current-text t)) + + (define in-menu-click? #f) + + (define/public (during-menu-click?) + ;; Called in Cocoa event-handling mode + in-menu-click?) (def/public-unimplemented set-background-to-gray) (def/public-unimplemented scroll) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index ec6e7074..54c3d34c 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -9,12 +9,16 @@ (unsafe!) (objc-unsafe!) -(provide item%) +(provide item% + install-control-font) (import-class NSFont) (define sys-font (tell NSFont systemFontOfSize: #:type _CGFloat 13)) +(define (install-control-font cocoa font) + (tellv cocoa setFont: sys-font)) + (defclass item% window% (inherit get-cocoa) @@ -38,4 +42,4 @@ (super-new) (define/public (init-font cocoa font) - (tellv cocoa setFont: sys-font))) + (install-control-font cocoa font))) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index fa855e30..c02bc1c0 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -85,7 +85,8 @@ (super-new [parent parent] [cocoa cocoa] - [no-show? (memq 'deleted style)]) + [no-show? (memq 'deleted style)] + [callback cb]) (set-size 0 0 32 50) ; (tellv content-cocoa sizeToFit) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 1d1f7526..6a09103f 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -34,7 +34,7 @@ (init parent label x y style font) - (inherit get-cocoa) + (inherit get-cocoa init-font) (super-new [parent parent] [cocoa (let* ([label (cond @@ -64,6 +64,7 @@ (tell (tell NSImageView alloc) init)))]) (cond [(string? label) + (init-font cocoa font) (tellv cocoa setSelectable: #:type _BOOL #f) (tellv cocoa setEditable: #:type _BOOL #f) (tellv cocoa setBordered: #:type _BOOL #f) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 1317a4c1..da4f6ec1 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -94,7 +94,7 @@ (define-unimplemented draw-tab) (define-unimplemented draw-tab-base) (define-unimplemented key-symbol-to-integer) -(define (get-control-font-size) 14) +(define (get-control-font-size) 13) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) (define (flush-display) (void)) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index cb082d63..0437014c 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -64,7 +64,7 @@ val style font) - (inherit get-cocoa set-focus) + (inherit get-cocoa set-focus init-font) (define horiz? (and (memq 'horizontal style) #t)) @@ -91,9 +91,11 @@ (begin (tellv button setTitle: #:type _NSString "") (set-ivar! button img (bitmap->image label))) - (tellv button setTitleWithMnemonic: #:type _NSString (if (string? label) - label - ""))) + (begin + (init-font button font) + (tellv button setTitleWithMnemonic: #:type _NSString (if (string? label) + label + "")))) (tellv button setButtonType: #:type _int NSRadioButton))) (tellv cocoa sizeToFit) (tellv cocoa setTarget: cocoa) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 06a6491f..aa967de4 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -58,12 +58,12 @@ (let loop ([hit hit]) (when hit (if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:)) - (tell hit doMouseMoved: event) + (unless (tell #:type _BOOL hit doMouseMoved: event) + (super-tell #:type _void mouseMoved: event)) (loop (tell hit superview))))))] - [-a _void (doMouseMoved: [_id event]) + [-a _BOOL (doMouseMoved: [_id event]) ;; called by mouseMoved: - (unless (do-mouse-event wx event 'motion #f #f #f) - (super-tell #:type _void mouseMoved: event))] + (do-mouse-event wx event 'motion #f #f #f)] [-a _void (mouseEntered: [_id event]) (unless (do-mouse-event wx event 'enter #f #f #f) (super-tell #:type _void mouseEntered: event))] @@ -116,7 +116,7 @@ [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) + (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) @@ -143,7 +143,7 @@ [alt-down (bit? modifiers NSAlternateKeyMask)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) + (if (send wx definitely-wants-event? m) (begin (queue-window-event wx (lambda () (send wx dispatch-on-event m #f))) @@ -261,6 +261,7 @@ (set-box! h (->long (NSSize-height s))))) (define/public (get-client-size w h) + ;; May be called in Cocoa event-handling mode (let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))]) (set-box! w (->long (NSSize-width s))) (set-box! h (->long (NSSize-height s))))) @@ -281,7 +282,7 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) - (define/public (wants-all-events?) + (define/public (definitely-wants-event? e) ;; Called in Cocoa event-handling mode #f) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 0d1a7965..30505b2b 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -15,7 +15,7 @@ (define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer) #:c-id scheme_set_on_atomic_timeout) -(define freezer-box (make-parameter null)) +(define freezer-box (make-parameter #f)) (define freeze-tag (make-continuation-prompt-tag)) ;; Runs `thunk' atomically, but cooperates with @@ -70,6 +70,10 @@ (let ([b (freezer-box)]) (cond [(not b) + ;; Ideally, this would count as an error that we can fix. It seems that we + ;; don't always have enough control to use the right eventspace with an + ;; unfreeze point, though, so just bail out with the default. + #; (internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) default] diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index ebed2371..d8057d83 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -353,6 +353,8 @@ (queue-window-event this (lambda () (on-combo-select i)))))) (define/public (on-combo-select i) (void)) + (define/public (set-combo-text t) (void)) + (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 5a5e50b7..9fbfe586 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -17,7 +17,7 @@ (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) (lambda (gtk a) (let ([wx (gtk->wx gtk)]) - (send wx remember-client-size + (send wx save-client-size (GtkAllocation-x a) (GtkAllocation-y a) (GtkAllocation-width a) @@ -28,6 +28,8 @@ (class % (init client-gtk) + (inherit remember-client-size) + (connect-size-allocate client-gtk) (define client-w 0) @@ -37,12 +39,13 @@ (define/public (on-client-size w h) (void)) - (define/public (remember-client-size x y w h) + (define/public (save-client-size x y w h) ;; Called in the Gtk event-loop thread (set! client-x x) (set! client-y y) (set! client-w w) (set! client-h h) + (remember-client-size w h) (queue-window-event this (lambda () (internal-on-client-size w h) (on-client-size w h)))) @@ -50,6 +53,10 @@ (define/public (internal-on-client-size w h) (void)) + (define/override (tentative-client-size w h) + (set! client-w w) + (set! client-h h)) + (define/override (get-client-size xb yb) (set-box! xb client-w) (set-box! yb client-h)) diff --git a/collects/mred/private/wx/gtk/const.rkt b/collects/mred/private/wx/gtk/const.rkt index 5a6b8d6d..5a3edc96 100644 --- a/collects/mred/private/wx/gtk/const.rkt +++ b/collects/mred/private/wx/gtk/const.rkt @@ -120,3 +120,13 @@ (define GDK_WINDOW_STATE_FULLSCREEN (1 . << . 4)) (define GDK_WINDOW_STATE_ABOVE (1 . << . 5)) (define GDK_WINDOW_STATE_BELOW (1 . << . 6)) + +(define GDK_HINT_POS (1 . << . 0)) +(define GDK_HINT_MIN_SIZE (1 . << . 1)) +(define GDK_HINT_MAX_SIZE (1 . << . 2)) +(define GDK_HINT_BASE_SIZE (1 . << . 3)) +(define GDK_HINT_ASPECT (1 . << . 4)) +(define GDK_HINT_RESIZE_INC (1 . << . 5)) +(define GDK_HINT_WIN_GRAVITY (1 . << . 6)) +(define GDK_HINT_USER_POS (1 . << . 7)) +(define GDK_HINT_USER_SIZE (1 . << . 8)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 2c6b2ac5..1ec33568 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -36,6 +36,22 @@ -> (values x y))) (define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) +(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) + +(define-cstruct _GdkGeometry ([min_width _int] + [min_height _int] + [max_width _int] + [max_height _int] + [base_width _int] + [base_height _int] + [width_inc _int] + [height_inc _int] + [min_aspect _double] + [max_aspect _double] + [win_gravity _int])) +(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void)) + + (define (handle-delete gtk) (let ([wx (gtk->wx gtk)]) (queue-window-event wx (lambda () @@ -45,14 +61,14 @@ (function-ptr handle-delete (_fun #:atomic? #t _GtkWidget -> _gboolean))) -(define (handle-configure gtk) - (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () - (send wx on-size 0 0))) +(define-signal-handler connect-configure "configure-event" + (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (send wx remember-size + (GdkEventConfigure-width a) + (GdkEventConfigure-height a))) #f)) -(define handle_configure - (function-ptr handle-configure - (_fun #:atomic? #t _GtkWidget -> _gboolean))) (define-cstruct _GdkEventWindowState ([type _int] [window _GtkWindow] @@ -80,7 +96,7 @@ (inherit get-gtk set-size on-size pre-on-char pre-on-event - get-client-delta) + get-client-delta get-size) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -105,7 +121,7 @@ (set-size x y w h) (g_signal_connect gtk "delete_event" handle_delete) - ;; (g_signal_connect gtk "configure_event" handle_configure) + (connect-configure gtk) (when label (gtk_window_set_title gtk label)) @@ -121,8 +137,21 @@ (gtk_box_pack_start vbox-gtk mb-gtk #t #t 0) (gtk_widget_show mb-gtk))) + (define saved-enforcements (vector 0 0 -1 -1)) + (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) - (void)) + (define (to-max v) (if (= v -1) #x3FFFFFFF v)) + (set! saved-enforcements (vector min-x min-y max-x max-y)) + (gtk_window_set_geometry_hints gtk gtk + (make-GdkGeometry min-x min-y + (to-max max-x) (to-max max-y) + 0 0 + inc-x inc-y + 0.0 0.0 + 0) + (bitwise-ior GDK_HINT_MIN_SIZE + GDK_HINT_MAX_SIZE + GDK_HINT_RESIZE_INC))) (define/override (get-top-win) this) @@ -149,15 +178,22 @@ (quotient (- sh fh) 2) -11111))))) - (define/override (set-top-position x y) + (define/public (set-top-position x y) + (when (and (vector? saved-enforcements) + (or (x . < . (vector-ref saved-enforcements 0)) + (let ([max-x (vector-ref saved-enforcements 1)]) + (and (max-x . > . -1) (x . > . max-x))) + (y . < . (vector-ref saved-enforcements 2)) + (let ([max-y (vector-ref saved-enforcements 3)]) + (and (max-y . > . -1) (y . > . max-y))))) + (enforce-size 0 0 -1 -1 1 1)) (gtk_widget_set_uposition gtk (if (= x -11111) -2 x) (if (= y -11111) -2 y))) - (define/override (get-size wb hb) - (let-values ([(w h) (gtk_window_get_size gtk)]) - (set-box! wb w) - (set-box! hb h))) + (define/override (set-top-size x y w h) + (set-top-position x y) + (gtk_window_resize gtk w h)) (define/override (direct-show on?) (super direct-show on?) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 20d9797d..783f3a04 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -19,7 +19,9 @@ _GdkEventMotion _GdkEventMotion-pointer (struct-out GdkEventMotion) _GdkEventCrossing _GdkEventCrossing-pointer - (struct-out GdkEventCrossing)) + (struct-out GdkEventCrossing) + _GdkEventConfigure _GdkEventConfigure-pointer + (struct-out GdkEventConfigure)) (define _GType _long) @@ -89,3 +91,11 @@ [detail _int] [focus _gboolean] [state _uint])) + +(define-cstruct _GdkEventConfigure ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [x _int] + [y _int] + [width _int] + [height _int])) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index d52a0dd4..42127c98 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -210,6 +210,32 @@ ;; ---------------------------------------- +(define (internal-error str) + (log-error + (apply string-append + (format "internal error: ~a" str) + (append + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)]))) + '("\n"))))) + (define window% (class widget% (init-field parent @@ -234,24 +260,47 @@ (define/public (get-window-gtk) (send parent get-window-gtk)) (define/public (move x y) - (set! save-x x) - (set! save-y y) - (when parent - (send parent set-child-position gtk x y))) + (set-size x y -1 -1)) + (define/public (set-size x y w h) - (unless (= x -11111) (set! save-x x)) - (unless (= y -11111) (set! save-y y)) - (unless (= w -1) (set! save-w w)) - (unless (= h -1) (set! save-h h)) - (if parent - (send parent set-child-size gtk save-x save-y save-w save-h) - (set-child-size gtk save-x save-y save-w save-h)) - (set-top-position save-x save-y)) - (define/public (set-top-position x y) (void)) + (unless (and (or (= x -11111) (= save-x x)) + (or (= y -11111) (= save-y y)) + (or (= w -1) (= save-w w)) + (or (= h -1) (= save-h h))) + (unless (= x -11111) (set! save-x x)) + (unless (= y -11111) (set! save-y y)) + (unless (= w -1) (set! save-w w)) + (unless (= h -1) (set! save-h h)) + (tentative-client-size (+ save-w client-delta-w) + (+ save-h client-delta-h)) + (if parent + (send parent set-child-size gtk save-x save-y save-w save-h) + (set-top-size save-x save-y save-w save-h)))) + (define/public (set-child-size child-gtk x y w h) (gtk_widget_set_size_request child-gtk w h) (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) + (define/public (set-top-size x y w h) (void)) + + (define/public (remember-size w h) + ;; called in event-pump thread + (unless (and (= save-w w) + (= save-h h)) + (set! save-w w) + (set! save-h h) + (queue-window-event this (lambda () (on-size w h))))) + + (define client-delta-w 0) + (define client-delta-h 0) + (define/public (remember-client-size w h) + ;; Called in the Gtk event-loop thread + (set! client-delta-w (max 0 (- save-w w))) + (set! client-delta-h (max 0 (- save-h h))) + (queue-window-event this (lambda () (on-size 0 0)))) + (define/public (tentative-client-size w h) + (void)) + (define/public (set-auto-size) (let ([req (make-GtkRequisition 0 0)]) (gtk_widget_size_request gtk req) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 7c92b581..b12ee9a8 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -20,15 +20,16 @@ (provide (protect wx-text-field%)) (define text-field-text% - (class100 text% (cb ret-cb control set-cb-mgrs!) + (class100 text% (cb ret-cb control set-cb-mgrs! record-text) (rename [super-on-char on-char]) - (inherit get-text last-position set-max-undo-history) + (inherit get-text last-position set-max-undo-history get-flattened-text) (private-field [return-cb ret-cb]) (private-field [block-callback 1] [callback (lambda (type) + (as-exit (lambda () (record-text (get-flattened-text)))) (when (zero? block-callback) (let ([e (make-object wx:control-event% type)]) (as-exit (lambda () @@ -88,7 +89,9 @@ this (lambda (wc cr) (set! without-callback wc) - (set! callback-ready cr)))]) + (set! callback-ready cr)) + (lambda (t) + (send c set-combo-text t)))]) (sequence (as-exit (lambda () From 5803fd7758979e660b9c34becac81181a7133b01 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 31 Jul 2010 11:48:17 -0600 Subject: [PATCH 119/462] another Gtk frame-size repair original commit: 3d9c68105ee20e9255e13e0c90c06392743f1741 --- collects/mred/private/wx/gtk/frame.rkt | 4 ++-- collects/mred/private/wx/gtk/window.rkt | 9 ++++----- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 1ec33568..5cf5b9b0 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -191,9 +191,9 @@ (if (= x -11111) -2 x) (if (= y -11111) -2 y))) - (define/override (set-top-size x y w h) + (define/override (really-set-size gtk x y w h) (set-top-position x y) - (gtk_window_resize gtk w h)) + (gtk_window_resize gtk (max 1 w) (max 1 h))) (define/override (direct-show on?) (super direct-show on?) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 42127c98..42782028 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -273,16 +273,15 @@ (unless (= h -1) (set! save-h h)) (tentative-client-size (+ save-w client-delta-w) (+ save-h client-delta-h)) - (if parent - (send parent set-child-size gtk save-x save-y save-w save-h) - (set-top-size save-x save-y save-w save-h)))) + (really-set-size gtk save-x save-y save-w save-h))) + + (define/public (really-set-size gtk x y w h) + (send parent set-child-size gtk x y w h)) (define/public (set-child-size child-gtk x y w h) (gtk_widget_set_size_request child-gtk w h) (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) - (define/public (set-top-size x y w h) (void)) - (define/public (remember-size w h) ;; called in event-pump thread (unless (and (= save-w w) From f30792e085b60da3ee3a111c33f5a3694353889c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 1 Aug 2010 06:57:03 -0600 Subject: [PATCH 120/462] fixes to bitmap%, especially mask vs. alpha mode original commit: 439683af5e938a0662139e5af90f65103d8c53cb --- collects/mred/private/wx/cocoa/image.rkt | 5 +++-- collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/queue.rkt | 4 ++-- collects/mred/private/wx/gtk/message.rkt | 6 ++++-- collects/mred/private/wx/gtk/pixbuf.rkt | 5 +++-- 5 files changed, 13 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index 808b9b42..4d4de0bd 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -57,8 +57,9 @@ [h (send bm get-height)] [str (make-bytes (* w h 4) 255)]) (send bm get-argb-pixels 0 0 w h str #f) - (when (send bm get-loaded-mask) - (send bm get-argb-pixels 0 0 w h str #t)) + (let ([mask (send bm get-loaded-mask)]) + (when mask + (send mask get-argb-pixels 0 0 w h str #t))) (as-entry (lambda () (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index da4f6ec1..3d7e2c10 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -95,7 +95,7 @@ (define-unimplemented draw-tab-base) (define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 13) -(define-unimplemented cancel-quit) +(define (cancel-quit) (void)) (define-unimplemented fill-private-color) (define (flush-display) (void)) (define-unimplemented write-resource) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 3211db05..9e45b71f 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -33,9 +33,9 @@ (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) [] - [-a _BOOL (applicationShouldTerminate: [_id app]) + [-a _int (applicationShouldTerminate: [_id app]) (queue-quit-event) - #f] + 0] [-a _BOOL (openPreferences: [_id app]) (log-error "prefs") #t]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index fdd2397c..b29ba9d1 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -56,8 +56,10 @@ [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]) - (gtk_image_new_from_pixbuf - (bitmap->pixbuf label))))] + (if (send label ok?) + (gtk_image_new_from_pixbuf + (bitmap->pixbuf label)) + (gtk_label_new_with_mnemonic ""))))] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index d94c74d5..cfcbca4e 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -36,8 +36,9 @@ [h (send bm get-height)] [str (make-bytes (* w h 4) 255)]) (send bm get-argb-pixels 0 0 w h str #f) - (when (send bm get-loaded-mask) - (send bm get-argb-pixels 0 0 w h str #t)) + (let ([mask (send bm get-loaded-mask)]) + (when mask + (send mask get-argb-pixels 0 0 w h str #t))) (as-entry (lambda () (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) From e0406cdeb7fe7ff88d705865abf9ba13f3b97570 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 1 Aug 2010 11:04:35 -0600 Subject: [PATCH 121/462] dialog show & button width fixes original commit: 202e18ef85226e08c9a4294ee49ae7f641d0295f --- collects/mred/private/app.rkt | 3 ++- collects/mred/private/wx/cocoa/button.rkt | 17 ++++++++++++- collects/mred/private/wx/cocoa/check-box.rkt | 2 +- collects/mred/private/wx/cocoa/dialog.rkt | 25 +++++++++++--------- collects/mred/private/wx/cocoa/queue.rkt | 2 ++ collects/mred/private/wx/common/queue.rkt | 1 + 6 files changed, 36 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/app.rkt b/collects/mred/private/app.rkt index ac3eaaa0..67948560 100644 --- a/collects/mred/private/app.rkt +++ b/collects/mred/private/app.rkt @@ -42,7 +42,8 @@ (dynamic-wind void (lambda () - (send af on-exit) + (as-exit (lambda () + (send af on-exit))) (unless (null? (wx:get-top-level-windows)) (wx:cancel-quit))) (lambda () diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 54b379a9..f6dd2c72 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -14,19 +14,22 @@ (objc-unsafe!) (provide button% + core-button% MyButton) ;; ---------------------------------------- (import-class NSButton NSView NSImageView) +(define MIN-BUTTON-WIDTH 72) + (define-objc-class MyButton NSButton #:mixins (FocusResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) -(defclass button% item% +(defclass core-button% item% (init parent cb label x y w h style font [button-type #f]) (init-field [event-type 'button]) @@ -55,6 +58,14 @@ (tellv cocoa setTitle: #:type _NSString "")]) (init-font cocoa font) (tellv cocoa sizeToFit) + (when (and (eq? event-type 'button) + (string? label)) + (let ([frame (tell #:type _NSRect cocoa frame)]) + (when ((NSSize-width (NSRect-size frame)) . < . MIN-BUTTON-WIDTH) + (tellv cocoa setFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize MIN-BUTTON-WIDTH + (NSSize-height (NSRect-size frame)))))))) cocoa)) (define cocoa (if (and button-type @@ -119,3 +130,7 @@ [time-stamp (current-milliseconds)]))) (def/public-unimplemented set-border)) + +(define button% + (class core-button% (super-new))) + diff --git a/collects/mred/private/wx/cocoa/check-box.rkt b/collects/mred/private/wx/cocoa/check-box.rkt index 7a7cacac..6241bb17 100644 --- a/collects/mred/private/wx/cocoa/check-box.rkt +++ b/collects/mred/private/wx/cocoa/check-box.rkt @@ -13,7 +13,7 @@ ;; ---------------------------------------- -(defclass check-box% button% +(defclass check-box% core-button% (inherit get-cocoa) (super-new [button-type NSSwitchButton] [event-type 'check-box]) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index ea21aaf5..423ff1da 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -2,6 +2,7 @@ (require scheme/class "../../syntax.rkt" "../common/queue.rkt" + "../../lock.rkt" "frame.rkt") (provide dialog%) @@ -13,19 +14,21 @@ (define/override (direct-show on?) (unless on? - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f))) + (as-entry + (lambda () + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f))))) (super direct-show on?)) (define/override (show on?) (if on? - (unless close-sema - (let ([s (make-semaphore)]) - (set! close-sema s) - (super show on?) - (yield s))) + (let ([s (as-entry + (lambda () + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + s)))]) + (super show on?) + (yield s) + (void)) (super show on?)))) - - - diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9e45b71f..0be2bbcf 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -200,6 +200,8 @@ (custodian-shutdown-all c))))))) (set! was-menu-bar #f))) +(define o (current-error-port)) + ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 0eb66a2d..d6b4309b 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -333,4 +333,5 @@ (lambda (k v) k))) (define (queue-quit-event) + ;; called in event-pump thread (queue-event main-eventspace (application-quit-handler) 'med)) From 4015840a60023e48ee7bfd4cdaef5f18915fd3da Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 1 Aug 2010 16:57:21 -0600 Subject: [PATCH 122/462] fix clipping-region issues original commit: d10669d34e79f77f0041ccfdb99079336c006e64 --- collects/mred/private/wx/cocoa/dc.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ddc01161..ff50d1cd 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -47,16 +47,19 @@ (cairo_surface_destroy surface)) (set! clip-width width) (set! clip-height height) - (cairo_rectangle cr 0 0 width height) - (cairo_clip cr)) + (reset-clip cr)) (define clip-width width) (define clip-height height) (define/override (reset-clip cr) (super reset-clip cr) - (cairo_rectangle cr 0 0 clip-width clip-height) - (cairo_clip cr)) + (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)]) + (cairo_get_matrix cr m) + (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0)) + (cairo_rectangle cr 0 0 clip-width clip-height) + (cairo_clip cr) + (cairo_set_matrix cr m))) (define cr #f) (set-bounds dx dy width height) From 48367ad6a2601d07f6bd5c6571f67851fd4cfd41 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 07:17:08 -0600 Subject: [PATCH 123/462] notes and docs original commit: 2631853a283e73193ee137bfab0d655190b22638 --- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 52 +++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 doc/release-notes/racket/Draw_and_GUI_5_5.txt diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt new file mode 100644 index 00000000..5d3b5c89 --- /dev/null +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -0,0 +1,52 @@ +Changes to the drawing toolbox: + + * The drawing portion of the old GUI toolbox is now available as a + separate layer: `racket/draw'. This layer can be used from plain + Racket independent of the `racket/gui' library, although + `racket/gui' re-exports `racket/draw'. + + The `racket/draw' library is built on top of the widely used Cairo + drawing library and Pango text-rendering library. + + * A color bitmap can have an alpha channel, instead of just a mask + bitmap. When drawing a bitmap, alpha channels are used more + consistently and automatically than mask bitmaps. More + significantly, drawing into a bitmap with an alpha channel + preserves the drawn alphas; for example, drawing a line in the + middle of an empty bitmap produces an image with non-zero alpha + only at the drawn line. + + Create a bitmap with an alpha channel by supplying #t as the new + `alpha?' argument to the `bitmap%' constructor, or by loading an + image with a type like 'unknown/alpha insteda of 'unknown or + 'unknown/mask. + + A newly created `bitmap%' has an empty content (i.e., white with + zero alpha), insteda of unspecified content. + + Images can be read into a `bitmap%' from from input ports, instead + of requiring a file path. + + * A `dc<%>' supports additional drawing transformations: a rotation + (via `set-rotation') and a general transformation matrix (via + `set-initial-matrix'). + + A transformation matrix has the form `(vector xx xy yx yy x0 y0)', + where a point (x1, y1) is transformed to a point (x2, y2) with + x2 = xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0. + + The old translation and scaling transformations apply after the + initial matrix. The new rotation transformation applies after the + other transformations. This layering is a little redundant, since + all transformations could be expressed in a single matrix, but it + is backward compatibile. + + * A `region%' can be created as independent of any `dc<%>', in which + cases it uses the drawing context's current transformation at the + time that it is installed as a clipping region. + + * The old 'xor mode for pens and brushes is no longer available. + +Changes to the GUI toolbox: + + [Nothing to report, yet.] From 6e114baa671bfa1e70da3b85e54bdf76c446d467 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 08:25:47 -0600 Subject: [PATCH 124/462] get-transformation, etc. methods on dc<%> original commit: 06a47a3c54fb04ad598372303ff36b779f994e9c --- collects/scribblings/gui/blurbs.rkt | 3 +- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 31 ++++++++++++++----- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/collects/scribblings/gui/blurbs.rkt b/collects/scribblings/gui/blurbs.rkt index ae2818d6..bd23f1db 100644 --- a/collects/scribblings/gui/blurbs.rkt +++ b/collects/scribblings/gui/blurbs.rkt @@ -152,8 +152,7 @@ information@|details|, even if the editor currently has delayed refreshing (see (define SeeMzParam @elem{(see @secref[#:doc reference-doc "parameters"])}) - (define DrawSizeNote @elem{Restrictions on the magnitude of - drawing coordinates are described with @scheme[dc<%>].}) + (define DrawSizeNote "") (define LineNumbering @elem{Lines are numbered starting with @scheme[0].}) (define ParagraphNumbering @elem{Paragraphs are numbered starting with @scheme[0].}) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index 5d3b5c89..e70af0de 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -29,23 +29,40 @@ Changes to the drawing toolbox: * A `dc<%>' supports additional drawing transformations: a rotation (via `set-rotation') and a general transformation matrix (via - `set-initial-matrix'). + `set-initial-matrix'). Scaling factors can be negative, which + corresponds to flipping the direction of drawing. A transformation matrix has the form `(vector xx xy yx yy x0 y0)', - where a point (x1, y1) is transformed to a point (x2, y2) with - x2 = xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0. + where a point (x1, y1) is transformed to a point (x2, y2) with x2 = + xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0, which is the usual + convention. + + New methods `translate', `scale', `rotate', and `transform' + simplify adding a further translation, scaling, rotation, or + arbitrary matrix transformation on top of the current + transformation. The new `get-translation' and `set-translation' + methods help to capture and restore transformation settings. The old translation and scaling transformations apply after the initial matrix. The new rotation transformation applies after the - other transformations. This layering is a little redundant, since - all transformations could be expressed in a single matrix, but it - is backward compatibile. + other transformations. This layering is redundant, since all + transformations can be expressed in a single matrix, but it is + backward-compatibile. Methods like `get-translation', + `set-translation', `scale', etc. help hide the reundancy. + + The alpha value of a `dc<%>' (as set by `set-alpha') is used for + all drawing operations, including drawing a bitmap. + + The `draw-bitmap' and `draw-bitmap-section' methods now smooth + bitmaps while scaling, so the `draw-bitmap-section-smooth' method + of `bitmap-dc%' simply calls `draw-bitmap-section'. * A `region%' can be created as independent of any `dc<%>', in which cases it uses the drawing context's current transformation at the time that it is installed as a clipping region. - * The old 'xor mode for pens and brushes is no longer available. + * The old 'xor mode for pens and brushes is no longer available + (since it is not supported by Cairo). Changes to the GUI toolbox: From 441ae9dd783a1b9ab456579b9dc093123bd6b6fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 10:32:13 -0600 Subject: [PATCH 125/462] submenus original commit: 6ae09fca1c54a02b6f824c0fd096010e79e72111 --- collects/mred/private/wx/cocoa/menu-item.rkt | 63 +++++++++++--------- collects/mred/private/wx/cocoa/menu.rkt | 16 +++-- collects/mred/private/wx/cocoa/radio-box.rkt | 6 ++ collects/mred/private/wx/gtk/menu-bar.rkt | 29 +++++---- collects/mred/private/wx/gtk/menu.rkt | 53 ++++++++++++---- collects/mred/private/wx/gtk/radio-box.rkt | 3 + collects/mred/private/wxlitem.rkt | 5 ++ 7 files changed, 119 insertions(+), 56 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 12999b1a..29365d24 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -41,35 +41,40 @@ (define/public (set-enabled-flag e?) (set! enabled? e?)) (define/public (get-enabled-flag) enabled?) + (define submenu #f) + (define/public (set-submenu m) (set! submenu m)) + (define/public (install menu) - (let ([item (tell (tell MyMenuItem alloc) - initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") - action: #:type _SEL #f - keyEquivalent: #:type _NSString "")]) - (set-ivar! item wx this) - (tellv menu addItem: item) - (tellv item setEnabled: #:type _BOOL enabled?) - (tellv item setTarget: item) - (tellv item setAction: #:type _SEL (selector selected:)) - (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) - (tellv item release))) + (if submenu + (send submenu install menu label) + (let ([item (tell (tell MyMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (set-ivar! item wx this) + (tellv menu addItem: item) + (tellv item setEnabled: #:type _BOOL enabled?) + (tellv item setTarget: item) + (tellv item setAction: #:type _SEL (selector selected:)) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (when shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) + (tellv item release)))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 804254c1..ccd37313 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -17,6 +17,9 @@ (define-struct mitem (item)) +(define (clean-label str) + (regexp-replace* #rx"&(.)" str "\\1")) + (defclass menu% object% (init-field label callback @@ -34,13 +37,13 @@ (set! cocoa (as-objc-allocation (tell (tell NSMenuItem alloc) - initWithTitle: #:type _NSString label + initWithTitle: #:type _NSString (clean-label label) action: #:type _SEL #f keyEquivalent: #:type _NSString ""))) (set! cocoa-menu (as-objc-allocation (tell (tell NSMenu alloc) - initWithTitle: #:type _NSString label))) + initWithTitle: #:type _NSString (clean-label label)))) (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) @@ -94,8 +97,11 @@ (send parent get-top-window)))) (public [append-item append]) - (define (append-item i label help-str chckable?) + (define (append-item i label help-str-or-submenu chckable?) (send i set-label label) + (when (help-str-or-submenu . is-a? . menu%) + (send i set-submenu help-str-or-submenu) + (send help-str-or-submenu set-parent this)) (set! items (append items (list (make-mitem i)))) (send i set-parent this) (when cocoa-menu @@ -131,9 +137,9 @@ (define/public (set-label item label) (adjust item (lambda (item-cocoa) - (tellv item-cocoa setTitle: #:type _NSString label)) + (tellv item-cocoa setTitle: #:type _NSString (clean-label label))) (lambda (mitem) - (send (mitem-item mitem) set-label label)))) + (send (mitem-item mitem) set-label (clean-label label))))) (define/public (check item on?) (adjust item diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 0437014c..6edf6fd0 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -117,6 +117,12 @@ 0 (set-focus))) + (define/public (enable-button i on?) + (tellv (tell (get-cocoa) + cellAtRow: #:type _NSUInteger (if horiz? 0 i) + column: #:type _NSUInteger (if horiz? i 0)) + setEnabled: #:type _BOOL on?)) + (define/public (set-selection i) (if (= i -1) (begin diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 52dfe4e5..0f371ad8 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -33,14 +33,23 @@ "_\\1") "&")) -(define-signal-handler connect-button-press "button-press-event" - (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) - (lambda (gtk event) +(define-signal-handler connect-select "select" + (_fun _GtkWidget -> _void) + (lambda (gtk) (let ([wx (gtk->wx gtk)]) (let ([frame (send wx get-top-window)]) - (constrained-reply (send wx get-eventspace) - (lambda () (send frame on-menu-click) #f) - #t))))) + (when frame + (constrained-reply (send frame get-eventspace) + (lambda () (send frame on-menu-click)) + (void))))))) + +(define top-menu% + (class widget% + (init-field parent) + (define/public (get-top-window) (send parent get-top-window)) + (super-new))) + + (defclass menu-bar% widget% (define menus null) @@ -48,8 +57,6 @@ (define gtk (gtk_menu_bar_new)) (super-new [gtk gtk]) - (connect-button-press gtk) - (define/public (get-gtk) gtk) (define top-wx #f) @@ -83,8 +90,10 @@ (public [append-menu append]) (define (append-menu menu title) (send menu set-parent this) - (let ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]) - (set! menus (append menus (list (list item menu)))) + (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] + [item-wx (new top-menu% [parent this] [gtk item])]) + (connect-select item) + (set! menus (append menus (list (list item menu item-wx)))) (let ([gtk (send menu get-gtk)]) (g_object_ref gtk) (gtk_menu_item_set_submenu item gtk)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 6b6a0c63..f5cf8247 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -25,6 +25,7 @@ (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_get_current_event_time (_fun -> _uint32)) (define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer @@ -55,12 +56,20 @@ (define/public (get-item) menu-item) + (define/public (removing-item) (void)) + (define/public (do-on-select) (send menu do-selected menu-item)) (define/public (on-select) (send menu on-select-item menu-item)))) +(define separator-item-handler% + (class object% + (define/public (get-item) #f) + (define/public (removing-item) (void)) + (super-new))) + (defclass menu% widget% (init label callback @@ -87,6 +96,15 @@ (send parent get-top-parent) (send parent get-top-window)))) + (define self-item #f) + (define remover void) + (define/public (set-self-item i r) (set! self-item i) (set! remover r)) + (define/public (get-item) self-item) + (define/public (removing-item) + (set! self-item #f) + (remover) + (set! remover void)) + (define on-popup #f) (define cancel-none-box (box #t)) @@ -152,23 +170,32 @@ (gtk_menu_item_set_accel_path item-gtk accel-path)))))])) (public [append-item append]) - (define (append-item i label help-str chckable?) - (let* ([item-gtk ((if chckable? - gtk_check_menu_item_new_with_mnemonic - gtk_menu_item_new_with_mnemonic) - (fixup-mneumonic label))] - [item (new menu-item-handler% - [gtk item-gtk] - [menu this] - [menu-item i])]) - (set! items (append items (list (list item item-gtk label chckable?)))) - (adjust-shortcut item-gtk label) + (define (append-item i label help-str-or-submenu chckable?) + (let ([item-gtk ((if chckable? + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + (fixup-mneumonic label))]) + (if (help-str-or-submenu . is-a? . menu%) + (let ([submenu help-str-or-submenu]) + (let ([gtk (send submenu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item-gtk gtk) + (send submenu set-parent this) + (send submenu set-self-item i + (lambda () (gtk_menu_item_set_submenu item-gtk #f))) + (set! items (append items (list (list submenu item-gtk label chckable?)))))) + (let ([item (new menu-item-handler% + [gtk item-gtk] + [menu this] + [menu-item i])]) + (set! items (append items (list (list item item-gtk label chckable?)))) + (adjust-shortcut item-gtk label))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk))) (define/public (append-separator) (let ([item-gtk (gtk_separator_menu_item_new)]) - (set! items (append items (list (list #f item-gtk #f #f)))) + (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk))) @@ -214,6 +241,7 @@ (cond [(null? items) null] [(zero? pos) + (send (caar items) removing-item) (gtk_container_remove gtk (cadar items)) (cdr items)] [else (cons (car items) @@ -225,6 +253,7 @@ (cond [(null? items) null] [(eq? (send (caar items) get-item) item) + (send (caar items) removing-item) (gtk_container_remove gtk (cadar items)) (cdr items)] [else (cons (car items) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index d113b269..4a1466a2 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -120,5 +120,8 @@ i)) -1)) + (define/public (enable-button i on?) + (gtk_widget_set_sensitive (list-ref radio-gtks i) on?)) + (define count (length labels)) (define/public (number) count)) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 536ecae7..597b3a62 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -233,6 +233,11 @@ major (filter-style style) font)) (set-c c) + (define/override enable + (case-lambda + [(on?) (super enable on?)] + [(i on?) (send c enable-button i on?)])) + (bounce c (button-focus i) From c9ef2562ad16a0abae7379f6b3a5322d58ad4965 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 10:47:42 -0600 Subject: [PATCH 126/462] try to connect gtk dialog with parent original commit: 03f5e140ea695ee49369265ec14efa2f15f68a2c --- collects/mred/private/wx/gtk/dialog.rkt | 7 ++++++- collects/mred/private/wx/gtk/procs.rkt | 7 ++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 9d3e4ee8..56ba1e50 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -13,6 +13,7 @@ (define GTK_WIN_POS_CENTER_ON_PARENT 4) (define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) (defclass dialog% frame% (inherit get-gtk @@ -22,6 +23,10 @@ (define close-sema #f) + (let ([p (get-parent)]) + (when p + (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) + (define/override (direct-show on?) (unless on? (when close-sema @@ -30,7 +35,7 @@ (super direct-show on?)) (define/override (center dir wrt) - (if #f ; (eq? dir 'both) + (if (eq? dir 'both) (gtk_window_set_position (get-gtk) (if (get-parent) GTK_WIN_POS_CENTER_ON_PARENT diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 7183f9ad..0c37c0c2 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -91,7 +91,12 @@ (define (get-control-font-size) 10) ;; FIXME (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) -(define (flush-display) (void)) + +(define _GdkDisplay (_cpointer 'GdkDisplay)) +(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define (flush-display) (gdk_display_flush (gdk_display_get_default))) + (define-unimplemented write-resource) (define-unimplemented get-resource) From 44b036b0d1a938adb1fa0c4e628789f65240bdf0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 12:44:47 -0600 Subject: [PATCH 127/462] gtk dialog% window hint original commit: 4457c510222dbcc450110b5aac6052428a43f4b7 --- collects/mred/private/wx/gtk/dialog.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 56ba1e50..25be184c 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -12,8 +12,11 @@ (define GTK_WIN_POS_CENTER 1) (define GTK_WIN_POS_CENTER_ON_PARENT 4) +(define GDK_WINDOW_TYPE_HINT_DIALOG 1) + (define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void)) (define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) (defclass dialog% frame% (inherit get-gtk @@ -23,6 +26,8 @@ (define close-sema #f) + (gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG) + (let ([p (get-parent)]) (when p (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) From e2676805599109c6b54ab539feaf11b856873998 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 14:05:51 -0600 Subject: [PATCH 128/462] better dialog support (sheets for Cocoa, centering in gtk) original commit: cc5cc94510bb7d473ccfe74467be1df296ffbea8 --- collects/mred/private/wx/cocoa/const.rkt | 5 +- collects/mred/private/wx/cocoa/dialog.rkt | 3 + collects/mred/private/wx/cocoa/frame.rkt | 112 ++++++++++++++++------ collects/mred/private/wx/gtk/dialog.rkt | 5 +- collects/mred/private/wx/gtk/frame.rkt | 17 +++- 5 files changed, 104 insertions(+), 38 deletions(-) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt index 8f607936..82c37e0b 100644 --- a/collects/mred/private/wx/cocoa/const.rkt +++ b/collects/mred/private/wx/cocoa/const.rkt @@ -2,11 +2,14 @@ (provide (except-out (all-defined-out) <<)) +(define (<< a b) (arithmetic-shift a b)) + (define NSTitledWindowMask 1) (define NSBorderlessWindowMask 0) (define NSClosableWindowMask 2) (define NSMiniaturizableWindowMask 4) (define NSResizableWindowMask 8) +(define NSUtilityWindowMask (1 . << . 4)) (define NSTexturedBackgroundWindowMask 256) (define NSBackingStoreBuffered 2) @@ -15,8 +18,6 @@ (define NSAnyEventMask #xffffffff) -(define (<< a b) (arithmetic-shift a b)) - (define NSAlphaShiftKeyMask (1 . << . 16)) (define NSShiftKeyMask (1 . << . 17)) (define NSControlKeyMask (1 . << . 18)) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 423ff1da..9ebc246f 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -21,6 +21,9 @@ (set! close-sema #f))))) (super direct-show on?)) + ;; #t result avoids children sheets + (define/override (get-sheet) #t) + (define/override (show on?) (if on? (let ([s (as-entry diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 190766c2..31f08de8 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -19,7 +19,7 @@ ;; ---------------------------------------- -(import-class NSWindow NSGraphicsContext NSMenu +(import-class NSWindow NSGraphicsContext NSMenu NSPanel NSApplication NSAutoreleasePool) (define front #f) @@ -27,8 +27,7 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) -(define-objc-class MyWindow NSWindow - #:mixins (FocusResponder KeyMouseResponder) +(define-objc-mixin (MyWindowMethods Superclass) [wx] [-a _scheme (getEventspace) (send wx get-eventspace)] @@ -61,6 +60,14 @@ (queue-window-event wx (lambda () (send wx on-activate #f))))]) +(define-objc-class MyWindow NSWindow + #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) + [wx]) + +(define-objc-class MyPanel NSPanel + #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) + [wx]) + (set-front-hook! (lambda () (values front (and front (send front get-eventspace))))) @@ -86,31 +93,39 @@ style) (init [is-dialog? #f]) - (inherit get-cocoa + (inherit get-cocoa get-parent pre-on-char pre-on-event) - (super-new [parent #f] + (super-new [parent parent] [cocoa - (as-objc-allocation - (tell (tell MyWindow alloc) - initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) - (make-NSRect (make-NSPoint x y) - (make-NSSize (max 30 w) - (max 0 h)))) - styleMask: #:type _int (if (memq 'no-caption style) - NSBorderlessWindowMask - (bitwise-ior - NSTitledWindowMask - (if is-dialog? - 0 - (bitwise-ior - NSClosableWindowMask - NSMiniaturizableWindowMask - (if (memq 'no-resize-border style) - 0 - NSResizableWindowMask))))) - backing: #:type _int NSBackingStoreBuffered - defer: #:type _BOOL NO))] + (let ([is-sheet? (and #f + is-dialog? + parent + (not (send parent frame-is-dialog?)))]) + (as-objc-allocation + (tell (tell (if is-sheet? + MyPanel + MyWindow) + alloc) + initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) + (make-NSRect (make-NSPoint x y) + (make-NSSize (max 30 w) + (max 0 h)))) + styleMask: #:type _int (if (memq 'no-caption style) + NSBorderlessWindowMask + (bitwise-ior + NSTitledWindowMask + (if is-sheet? NSUtilityWindowMask 0) + (if is-dialog? + 0 + (bitwise-ior + NSClosableWindowMask + NSMiniaturizableWindowMask + (if (memq 'no-resize-border style) + 0 + NSResizableWindowMask))))) + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO)))] [no-show? #t]) (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) @@ -126,6 +141,9 @@ (as-objc-allocation (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) + (define is-a-dialog? is-dialog?) + (define/public (frame-is-dialog?) is-a-dialog?) + (define/public (clean-up) ;; When a window is resized, then any drawing that is in flight ;; might draw outside the canvas boundaries. Just refresh everything. @@ -133,6 +151,10 @@ (when label (tellv cocoa setTitle: #:type _NSString label)) + + (define child-sheet #f) + (define/public (get-sheet) child-sheet) + (define/public (set-sheet s) (set! child-sheet s)) (define/public (direct-show on?) (as-entry @@ -142,8 +164,25 @@ (set! front #f) (send empty-mb install)) (if on? - (tellv cocoa makeKeyAndOrderFront: #f) + (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (not (send p get-sheet))))) + (let ([p (get-parent)]) + (send p set-sheet this) + (tell (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) + (tellv cocoa makeKeyAndOrderFront: #f)) (begin + (when is-a-dialog? + (let ([p (get-parent)]) + (when (and p + (eq? this (send p get-sheet))) + (send p set-sheet #f)))) (tellv cocoa orderOut: #f) (let ([next (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] @@ -185,11 +224,22 @@ (move x y)) (let ([f (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: - #:type _NSRect (make-NSRect (make-NSPoint (NSPoint-x (NSRect-origin f)) - (- (NSPoint-y (NSRect-origin f)) - (- h - (NSSize-height (NSRect-size f))))) - (make-NSSize w h)) + #:type _NSRect (make-NSRect + (make-NSPoint (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (eq? this (send p get-sheet))))) + ;; need to re-center sheet: + (let* ([p (get-parent)] + [px (send p get-x)] + [pw (send p get-width)]) + (+ px (/ (- pw w) 2))) + ;; keep current x position: + (NSPoint-x (NSRect-origin f))) + (- (NSPoint-y (NSRect-origin f)) + (- h + (NSSize-height (NSRect-size f))))) + (make-NSSize w h)) display: #:type _BOOL #t))) (define/override (move x y) (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y)))) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 25be184c..eee9934b 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -40,7 +40,10 @@ (super direct-show on?)) (define/override (center dir wrt) - (if (eq? dir 'both) + ;; We're supposed to use gtk_window_set_position() for dialogs, + ;; but we must be doing something else wrong so that it doesn't + ;; work. + (if #f ; (eq? dir 'both) (gtk_window_set_position (get-gtk) (if (get-parent) GTK_WIN_POS_CENTER_ON_PARENT diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 5cf5b9b0..06e8ee90 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -96,7 +96,8 @@ (inherit get-gtk set-size on-size pre-on-char pre-on-event - get-client-delta get-size) + get-client-delta get-size + get-parent) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -161,21 +162,29 @@ (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] + [sx-box (box 0)] + [sy-box (box 0)] [sw-box (box 0)] [sh-box (box 0)]) (get-size w-box h-box) - (display-size sw-box sh-box #t) + (let ([p (get-parent)]) + (if p + (begin + (send p get-size sw-box sh-box) + (set-box! sx-box (send p get-x)) + (set-box! sy-box (send p get-y))) + (display-size sw-box sh-box #t))) (let* ([sw (unbox sw-box)] [sh (unbox sh-box)] [fw (unbox w-box)] [fh (unbox h-box)]) (set-top-position (if (or (eq? dir 'both) (eq? dir 'horizontal)) - (quotient (- sw fw) 2) + (+ (unbox sx-box) (quotient (- sw fw) 2)) -11111) (if (or (eq? dir 'both) (eq? dir 'vertical)) - (quotient (- sh fh) 2) + (+ (unbox sy-box) (quotient (- sh fh) 2)) -11111))))) (define/public (set-top-position x y) From 44a8d8ce2bfb47602cda2c9e8574517cfec7e981 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 18:52:16 -0600 Subject: [PATCH 129/462] canvas scrollbars and borders original commit: 6cb07301c1747c12232f6563f13cd4ae0541ebda --- collects/mred/private/wx/cocoa/canvas.rkt | 162 +++++++++++++++------ collects/mred/private/wx/cocoa/window.rkt | 18 ++- collects/mred/private/wx/common/cursor.rkt | 3 +- collects/mred/private/wx/common/freeze.rkt | 12 +- collects/mred/private/wx/gtk/canvas.rkt | 78 ++++++++-- collects/mred/private/wx/gtk/types.rkt | 19 ++- collects/mred/private/wx/gtk/utils.rkt | 4 +- 7 files changed, 219 insertions(+), 77 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 072401c9..8bc23e58 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -30,23 +30,24 @@ #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (drawRect: [_NSRect r]) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event)) + (unless (send wx reject-partial-update r) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState)))) + (send wx queue-paint) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event))) (-a _void (viewWillMoveToWindow: [_id w]) (when wx (queue-window-event wx (lambda () (send wx fix-dc))))) @@ -55,6 +56,37 @@ (-a _void (onVScroll: [_id scroller]) (when wx (send wx do-scroll 'vertical scroller)))) +(define-objc-class FrameView NSView + [] + (-a _void (drawRect: [_NSRect r]) + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextFillRect cg r)) + (tellv ctx restoreGraphicsState)))) + +(define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) +(define-cocoa NSRectFill (_fun _NSRect -> _void)) + +(define-objc-class FocusView NSView + [on?] + (-a _void (setFocusState: [_BOOL is-on?]) + (set! on? is-on?)) + (-a _void (drawRect: [_NSRect r]) + (when on? + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (NSSetFocusRingStyle 0) + (let ([r (tell #:type _NSRect self bounds)]) + (NSRectFill (make-NSRect (make-NSPoint + (+ (NSPoint-x (NSRect-origin r)) 2) + (+ (NSPoint-y (NSRect-origin r)) 2)) + (make-NSSize + (- (NSSize-width (NSRect-size r)) 4) + (- (NSSize-height (NSRect-size r)) 4))))) + (tellv ctx restoreGraphicsState))))) + (define-objc-class MyComboBox NSComboBox #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSComboBoxDelegate) @@ -104,15 +136,27 @@ is-shown-to-root? move get-x get-y on-size - register-as-child) + register-as-child + get-size get-position) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) (define hscroll-ok? (and (memq 'hscroll style) #t)) (define hscroll? hscroll-ok?) + (define-values (x-margin y-margin) + (cond + [(memq 'control-border style) (values 3 3)] + [(memq 'border style) (values 1 1)] + [else (values 0 0)])) + (define canvas-style style) + (define/override (focus-is-on on?) + (when (memq 'control-border canvas-style) + (tellv cocoa setFocusState: #:type _BOOL on?) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t))) + (define is-visible? #f) ;; Avoid multiple queued paints: @@ -148,16 +192,22 @@ [parent parent] [cocoa (as-objc-allocation - (tell (tell NSView alloc) + (tell (tell (cond + [(memq 'control-border style) FocusView] + [(memq 'border style) FrameView] + [else NSView]) + alloc) initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) - (make-NSSize w h))))] + (make-NSSize (max w (* 2 x-margin)) + (max h (* 2 y-margin))))))] [no-show? (memq 'deleted style)]) (define cocoa (get-cocoa)) (define content-cocoa (let ([r (make-NSRect (make-NSPoint 0 0) - (make-NSSize w h))]) + (make-NSSize (max 0 (- w (* 2 x-margin))) + (max 0 (- h (* 2 y-margin)))))]) (as-objc-allocation (tell (tell (if is-combo? MyComboBox MyView) alloc) initWithFrame: #:type _NSRect r)))) @@ -213,30 +263,33 @@ (when tr (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) (set! tr #f)) - (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0)) - (- h (if hscroll? scroll-width 0)))] - [pos (make-NSPoint 0 (if hscroll? scroll-width 0))]) + (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) + (- h (if hscroll? scroll-width 0) y-margin y-margin))] + [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) (set! tr (tell #:type _NSInteger content-cocoa - addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) sz) + addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) owner: content-cocoa userData: #f assumeInside: #:type _BOOL #f))) (when v-scroller (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width) - (if hscroll? - scroll-width - 0)) + (make-NSPoint (- w scroll-width x-margin) + (+ (if hscroll? + scroll-width + 0) + y-margin)) (make-NSSize scroll-width - (- h (if hscroll? scroll-width 0)))))) + (max 0 (- h (if hscroll? scroll-width 0) + x-margin x-margin)))))) (when h-scroller (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (- w (if vscroll? scroll-width 0)) + (make-NSPoint x-margin y-margin) + (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) + x-margin x-margin)) scroll-width)))) (fix-dc) (on-size 0 0)) @@ -262,11 +315,10 @@ [(and vscroll? (not v?)) (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) (set! vscroll? v?) - (let ([r (tell #:type _NSRect cocoa frame)]) - (do-set-size (NSPoint-x (NSRect-origin r)) - (NSPoint-y (NSRect-origin r)) - (NSSize-width (NSRect-size r)) - (NSSize-height (NSRect-size r))))))) + (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) + (get-position x y) + (get-size w h) + (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) (define/public (set-scrollbars h-step v-step h-len v-len @@ -309,12 +361,14 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width) - (if hscroll? - scroll-width - 0)) + (make-NSPoint (- w scroll-width x-margin) + (+ (if hscroll? + scroll-width + 0) + y-margin)) (make-NSSize scroll-width - (max (- h (if hscroll? scroll-width 0)) + (max (- h (if hscroll? scroll-width 0) + y-margin y-margin) (+ scroll-width 10)))))) 1 1))) @@ -324,8 +378,9 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (max (- w (if vscroll? scroll-width 0)) + (make-NSPoint x-margin y-margin) + (make-NSSize (max (- w (if vscroll? scroll-width 0) + x-margin x-margin) (+ scroll-width 10)) scroll-width)))) 1 @@ -401,6 +456,25 @@ (not (memq 'no-autoclear canvas-style)) bg-col))) + (define/public (reject-partial-update r) + ;; Called in the event-pump thread. + ;; A transparent canvas cannot handle a partial update. + (and (or + ;; Multiple clipping rects? + (let ([i (malloc _NSInteger)] + [r (malloc 'atomic _pointer)]) + (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r + count: #:type _pointer i) + ((ptr-ref i _NSInteger) . > . 1)) + ;; Single clipping not whole area? + (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] + [s2 (NSRect-size r)]) + (or ((NSSize-width s2) . < . (NSSize-width s1)) + ((NSSize-height s2) . < . (NSSize-height s1))))) + (begin + (queue-window-event this (lambda () (refresh))) + #t))) + (define/public (do-scroll direction scroller) ;; Called from the Cocoa handler thread (let ([part (tell #:type _int scroller hitPart)]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index aa967de4..7cd2f75a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -28,14 +28,18 @@ #t] [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) - (queue-window-event wx (lambda () - (send wx on-set-focus))) - #t)] + (begin + (send wx focus-is-on #t) + (queue-window-event wx (lambda () + (send wx on-set-focus))) + #t))] [-a _BOOL (resignFirstResponder) (and (super-tell resignFirstResponder) - (queue-window-event wx (lambda () - (send wx on-kill-focus))) - #t)]) + (begin + (send wx focus-is-on #f) + (queue-window-event wx (lambda () + (send wx on-kill-focus))) + #t))]) (define-objc-mixin (KeyMouseResponder Superclass) [wx] @@ -169,6 +173,8 @@ (unless no-show? (show #t)) + (define/public (focus-is-on on?) (void)) + (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) (define/public (get-cocoa-window) (send parent get-cocoa-window)) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt index a56df307..f2767586 100644 --- a/collects/mred/private/wx/common/cursor.rkt +++ b/collects/mred/private/wx/common/cursor.rkt @@ -15,7 +15,8 @@ (case-args args [([(symbol-in arrow bullseye cross hand ibeam watch blank - size-n/s size-e/w size-ne/sw size-nw/se) + size-n/s size-e/w size-ne/sw size-nw/se + arrow+watch) sym]) (or (hash-ref standards sym #f) (let ([c (new cursor-driver%)]) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 30505b2b..d84cd487 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -63,10 +63,12 @@ '("\n"))))) ;; FIXME: waiting 200msec is not a good enough rule. -(define (constrained-reply es thunk default [should-give-up? - (let ([now (current-inexact-milliseconds)]) - (lambda () - ((current-inexact-milliseconds) . > . (+ now 200))))]) +(define (constrained-reply es thunk default + [should-give-up? + (let ([now (current-inexact-milliseconds)]) + (lambda () + ((current-inexact-milliseconds) . > . (+ now 200))))] + #:fail-result [fail-result default]) (let ([b (freezer-box)]) (cond [(not b) @@ -76,7 +78,7 @@ #; (internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) - default] + fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") default] diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index d8057d83..abe343ea 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -43,6 +43,8 @@ (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) + (define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) #:c-id g_object_set) @@ -79,16 +81,32 @@ (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) -(define (handle-expose gtk event) - (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) +(define-signal-handler connect-expose "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (g_object_get_window gtk) gc #t + 0 0 32000 32000))) + (send wx queue-paint)) + #t)) + +(define-signal-handler connect-expose-border "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let* ([win (g_object_get_window gtk)] + [gc (gdk_gc_new win)] + [gray #x8000]) (when gc - (gdk_draw_rectangle (g_object_get_window gtk) gc #t - 0 0 32000 32000))) - (send wx queue-paint)) - #t) -(define handle_expose - (function-ptr handle-expose (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _gboolean))) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) + (let ([r (GdkEventExpose-area event)]) + (gdk_draw_rectangle win gc #t + (GdkRectangle-x r) + (GdkRectangle-y r) + (GdkRectangle-width r) + (GdkRectangle-height r))) + (gdk_gc_unref gc))))) (define (handle-value-changed-h gtk ignored) (let ([wx (gtk->wx gtk)]) @@ -118,6 +136,10 @@ on-size register-as-child get-top-win) (define is-combo? (memq 'combo style)) + (define has-border? (or (memq 'border style) + (memq 'control-border style))) + + (define margin (if has-border? 1 0)) (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) (cond @@ -133,6 +155,8 @@ [hscroll (gtk_hscrollbar_new hadj)] [vscroll (gtk_vscrollbar_new vadj)] [resize-box (gtk_drawing_area_new)]) + (when has-border? + (gtk_container_set_border_width h margin)) (gtk_box_pack_start h v #t #t 0) (gtk_box_pack_start v client-gtk #t #t 0) (gtk_box_pack_start h v2 #f #f 0) @@ -148,11 +172,27 @@ (gtk_widget_show h2) (gtk_widget_show resize-box) (gtk_widget_show client-gtk) - (values client-gtk h hadj vadj h2 v2 resize-box)))] + (unless (memq 'hscroll style) + (gtk_widget_hide hscroll) + (gtk_widget_hide resize-box)) + (unless (memq 'vscroll style) + (gtk_widget_hide v2)) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box))))] [is-combo? (let* ([gtk (gtk_combo_box_entry_new_text)] [orig-entry (gtk_bin_get_child gtk)]) (values orig-entry gtk #f #f #f #f #f))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (gtk_hbox_new #f 0)]) + (gtk_box_pack_start h client-gtk #t #t 0) + (gtk_container_set_border_width h margin) + (connect-expose-border h) + (gtk_widget_show client-gtk) + (values client-gtk h #f #f #f #f #f))] [else (let ([client-gtk (gtk_drawing_area_new)]) (values client-gtk client-gtk #f #f #f #f #f))])) @@ -192,7 +232,7 @@ (GtkRequisition-height r) (GtkRequisition-height r)))) - (g_signal_connect client-gtk "expose-event" handle_expose) + (connect-expose client-gtk) (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK @@ -217,10 +257,8 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events?) #t) - ;; For the moment, the client area always starts at the - ;; control area's top left (define/override (get-client-delta) - (values 0 0)) + (values margin margin)) ;; Avoid multiple queued paints: (define paint-queued? #f) @@ -272,7 +310,14 @@ (when vscroll-gtk (if v? (gtk_widget_show vscroll-gtk) - (gtk_widget_hide vscroll-gtk)))) + (gtk_widget_hide vscroll-gtk))) + (when (and hscroll-gtk vscroll-gtk) + (cond + [(and v? h?) + (gtk_widget_show resize-box)] + [(and v? (not h?)) + ;; remove corner + (gtk_widget_hide resize-box)]))) (define/public (set-scrollbars h-step v-step h-len v-len @@ -369,4 +414,5 @@ (def/public-unimplemented view-start) (define/public (set-resize-corner on?) (void)) - (def/public-unimplemented get-virtual-size))) + (define/public (get-virtual-size xb yb) (set-box! xb 10) (set-box! yb 10)))) + diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 783f3a04..6d2aa48c 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -5,7 +5,6 @@ (provide _GdkWindow _GtkWidget _GtkWindow _gpointer - _GdkEventExpose _GType _fnpointer @@ -21,7 +20,10 @@ _GdkEventCrossing _GdkEventCrossing-pointer (struct-out GdkEventCrossing) _GdkEventConfigure _GdkEventConfigure-pointer - (struct-out GdkEventConfigure)) + (struct-out GdkEventConfigure) + _GdkEventExpose _GdkEventExpose-pointer + (struct-out GdkEventExpose) + (struct-out GdkRectangle)) (define _GType _long) @@ -31,7 +33,6 @@ (define _GtkWindow _GtkWidget) (define _gpointer _GtkWidget) -(define _GdkEventExpose (_cpointer 'GdkEventExpose)) (define _GdkDevice (_cpointer 'GdkDevice)) @@ -99,3 +100,15 @@ [y _int] [width _int] [height _int])) + +(define-cstruct _GdkRectangle ([x _int] + [y _int] + [width _int] + [height _int])) + +(define-cstruct _GdkEventExpose ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [area _GdkRectangle] + [region _pointer] + [count _int])) \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index a8e27d4a..9175c90f 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -75,8 +75,8 @@ (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) -(define-gobj g_object_ref (_fun _GtkWidget -> _void)) -(define-gobj g_object_unref (_fun _GtkWidget -> _void)) +(define-gobj g_object_ref (_fun _pointer -> _void)) +(define-gobj g_object_unref (_fun _pointer -> _void)) (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) From 57467087939c222f1546096809a1d4737cf2a3b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 12:19:51 -0600 Subject: [PATCH 130/462] auto-scroll canvases and frame status lines original commit: c42d95216eb48e94a48364fb01b0e6d4a70d1534 --- collects/mred/private/mrtop.rkt | 26 +++- collects/mred/private/wx/cocoa/canvas.rkt | 153 +++++++++++++++----- collects/mred/private/wx/cocoa/dc.rkt | 11 +- collects/mred/private/wx/gtk/canvas.rkt | 119 ++++++++++++--- collects/mred/private/wx/gtk/dc.rkt | 7 +- collects/mred/private/wx/gtk/message.rkt | 4 + collects/scribblings/gui/canvas-class.scrbl | 6 +- collects/tests/gracket/item.rkt | 3 +- 8 files changed, 254 insertions(+), 75 deletions(-) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 719588d9..a99ca6a1 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -12,6 +12,7 @@ "wx.ss" "wxtop.ss" "wxpanel.ss" + "wxitem.ss" "mrwindow.ss" "mrcontainer.ss") @@ -41,6 +42,10 @@ (define-keywords top-level-window%-keywords window%-keywords container%-keywords area%-keywords) + (define-local-member-name + do-create-status-line + do-set-status-text) + (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) @@ -111,15 +116,25 @@ [on-message (lambda (m) (void))]) (private-field [wx #f] + [mid-panel #f] ;; supports status line [wx-panel #f] + [status-message #f] [finish (entry-point (lambda (top-level hide-panel?) - (set! wx-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (send (send mid-panel area-parent) add-child mid-panel) + (set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f)) (send (send wx-panel area-parent) add-child wx-panel) (send top-level set-container wx-panel) (when hide-panel? - (send wx-panel show #f)) + (send mid-panel show #f)) top-level))]) + (public + [do-create-status-line (lambda () + (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) + (send status-message stretchable-in-x #t))] + [do-set-status-text (lambda (s) + (send status-message set-label s))]) (sequence (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor)))) @@ -128,7 +143,8 @@ (class100*/kw basic-top-level-window% () [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) top-level-window%-keywords] - (inherit on-traverse-char on-system-menu-char) + (inherit on-traverse-char on-system-menu-char + do-create-status-line do-set-status-text) (sequence (let ([cwho '(constructor frame)]) (check-label-string cwho label) @@ -164,8 +180,8 @@ (send wx handle-menu-key e)))] [on-mdi-activate (lambda (on?) (void))] [on-toolbar-button-click (lambda () (void))] - [create-status-line (entry-point (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t))))] - [set-status-text (lambda (s) (send wx set-status-text s))] + [create-status-line (entry-point (lambda () (unless status-line? (do-create-status-line) (set! status-line? #t))))] + [set-status-text (lambda (s) (do-set-status-text s))] [has-status-line? (lambda () status-line?)] [iconize (entry-point (lambda (on?) (send wx iconize on?)))] [is-iconized? (entry-point (lambda () (send wx iconized?)))] diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 8bc23e58..8908dd79 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -61,9 +61,11 @@ (-a _void (drawRect: [_NSRect r]) (let ([ctx (tell NSGraphicsContext currentContext)]) (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [r (tell #:type _NSRect self bounds)]) (CGContextSetRGBFillColor cg 0 0 0 1.0) - (CGContextFillRect cg r)) + (CGContextAddRect cg r) + (CGContextStrokePath cg)) (tellv ctx restoreGraphicsState)))) (define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) @@ -144,11 +146,15 @@ (define hscroll-ok? (and (memq 'hscroll style) #t)) (define hscroll? hscroll-ok?) - (define-values (x-margin y-margin) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + + (define-values (x-margin y-margin x-sb-margin y-sb-margin) (cond - [(memq 'control-border style) (values 3 3)] - [(memq 'border style) (values 1 1)] - [else (values 0 0)])) + [(memq 'control-border style) (values 3 3 3 3)] + [(memq 'border style) (values 1 1 0 0)] + [else (values 0 0 0 0)])) (define canvas-style style) @@ -193,6 +199,7 @@ [cocoa (as-objc-allocation (tell (tell (cond + [is-combo? NSView] [(memq 'control-border style) FocusView] [(memq 'border style) FrameView] [else NSView]) @@ -236,7 +243,9 @@ (+ (NSPoint-x p) (if is-combo? 2 0)) (- (NSPoint-y p) (if is-combo? 22 0)) (max 1 (- (unbox xb) (if is-combo? 22 0))) - (unbox yb)))) + (unbox yb) + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0)))) (define/override (get-client-size xb yb) (super get-client-size xb yb) @@ -276,27 +285,25 @@ (when v-scroller (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-margin) + (make-NSPoint (- w scroll-width x-sb-margin) (+ (if hscroll? scroll-width 0) - y-margin)) + y-sb-margin)) (make-NSSize scroll-width (max 0 (- h (if hscroll? scroll-width 0) - x-margin x-margin)))))) + x-sb-margin x-sb-margin)))))) (when h-scroller (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint x-margin y-margin) + (make-NSPoint x-sb-margin y-sb-margin) (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) - x-margin x-margin)) + x-sb-margin x-sb-margin)) scroll-width)))) (fix-dc) + (when auto-scroll? + (reset-auto-scroll 0 0)) (on-size 0 0)) - (define/override (client-y-offset) - (if hscroll? - scroll-width - 0)) (define/public (show-scrollbars h? v?) (let ([h? (and h? hscroll-ok?)] @@ -325,16 +332,62 @@ h-page v-page h-pos v-pos auto?) - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (when a? (fix-dc))) ; disable scroll offsets + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) + (set! virtual-width #f) + (set! virtual-height #f)])) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) + + (define/private (refresh-for-autoscroll) + (fix-dc) + (refresh)) (define (update which scroll- v) (if (eq? which 'vertical) @@ -361,14 +414,14 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-margin) + (make-NSPoint (- w scroll-width x-sb-margin) (+ (if hscroll? scroll-width 0) - y-margin)) + y-sb-margin)) (make-NSSize scroll-width (max (- h (if hscroll? scroll-width 0) - y-margin y-margin) + y-sb-margin y-sb-margin) (+ scroll-width 10)))))) 1 1))) @@ -378,9 +431,9 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint x-margin y-margin) + (make-NSPoint x-sb-margin y-sb-margin) (make-NSSize (max (- w (if vscroll? scroll-width 0) - x-margin x-margin) + x-sb-margin x-sb-margin) (+ scroll-width 10)) scroll-width)))) 1 @@ -501,10 +554,12 @@ 'thumb] [else #f])]) (when kind - (on-scroll (new scroll-event% - [event-type kind] - [direction direction] - [position (get-scroll-pos direction)]))))))) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)])))))))) (constrained-reply (get-eventspace) (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) @@ -547,9 +602,31 @@ in-menu-click?) (def/public-unimplemented set-background-to-gray) - (def/public-unimplemented scroll) + + (define/public (scroll x y) + (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) + (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) + (when auto-scroll? (refresh-for-autoscroll))) + (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (scroll-pos h-scroller) + 0)) + (set-box! yb (if virtual-height + (scroll-pos v-scroller) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + (define/public (set-resize-corner on?) (void)) - (def/public-unimplemented get-virtual-size))) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ff50d1cd..9c738213 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -13,7 +13,9 @@ (provide dc% _CGContextRef CGContextSetRGBFillColor - CGContextFillRect) + CGContextFillRect + CGContextAddRect + CGContextStrokePath) (define _CGContextRef (_cpointer 'CGContextRef)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) @@ -21,6 +23,8 @@ (define-appserv CGContextFlush (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) (define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) (define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) @@ -29,7 +33,7 @@ (init context dx dy width height) (super-new) - (inherit reset-cr) + (inherit reset-cr set-auto-scroll) (define the-context context) ;; retain as long as we need `cg' (define cg (tell #:type _CGContextRef context graphicsPort)) @@ -64,11 +68,12 @@ (define cr #f) (set-bounds dx dy width height) - (define/public (reset-bounds dx dy width height) + (define/public (reset-bounds dx dy width height auto-dx auto-dy) (let ([old-cr cr]) (when old-cr (set! cr #f) (cairo_destroy old-cr))) + (set-auto-scroll auto-dx auto-dy) (CGContextScaleCTM cg 1 -1) (CGContextTranslateCTM cg (- old-dx) (- old-dy)) (set-bounds dx dy width height) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index abe343ea..c21d443e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -141,6 +141,10 @@ (define margin (if has-border? 1 0)) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) (cond [(or (memq 'hscroll style) @@ -289,13 +293,24 @@ (define/public (reset-child-dcs) (when (dc . is-a? . dc%) - (send dc reset-dc))) + (reset-dc))) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?) (when on? (reset-child-dcs))) + (define/private (reset-dc) + (if auto-scroll? + (send dc reset-dc + (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0) + (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0)) + (send dc reset-dc 0 0))) + (define/override (internal-on-client-size w h) - (send dc reset-dc)) + (reset-dc)) (define/override (on-client-size w h) (let ([xb (box 0)] [yb (box 0)]) @@ -319,20 +334,59 @@ ;; remove corner (gtk_widget_hide resize-box)]))) + (define/private (configure-adj adj scroll-gtk len page pos) + (when (and scroll-gtk adj) + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) + (define/public (set-scrollbars h-step v-step h-len v-len h-page v-page h-pos v-pos auto?) - (when hscroll-adj - (gtk_adjustment_configure hscroll-adj h-pos 0 h-len 1 h-page h-page)) - (when vscroll-adj - (gtk_adjustment_configure vscroll-adj v-pos 0 v-len 1 v-page v-page))) + (let ([h-page (if (zero? h-len) 0 h-page)] + [v-page (if (zero? v-len) 0 v-page)]) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) + (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) - (define/private (dispatch which proc) + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) + + (define/private (refresh-for-autoscroll) + (reset-dc) + (refresh)) + + (define/private (dispatch which proc [default (void)]) (if (eq? which 'vertical) - (when vscroll-adj (proc vscroll-adj)) - (when hscroll-adj (proc hscroll-adj)))) + (if vscroll-adj (proc vscroll-adj) default) + (if hscroll-adj (proc hscroll-adj) default))) (define/public (set-scroll-page which v) (dispatch which (lambda (adj) @@ -349,13 +403,14 @@ (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) (define/public (get-scroll-page which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_page_size adj) - (gtk_adjustment_get_page_size adj)))))) + (->long (dispatch which gtk_adjustment_get_page_size 0))) (define/public (get-scroll-range which) - (->long (dispatch which gtk_adjustment_get_upper))) + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0))) (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value))) + (->long (dispatch which gtk_adjustment_get_value 0))) (define clear-bg? (and (not (memq 'transparent style)) @@ -403,16 +458,38 @@ (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction direction] - [position (get-scroll-pos direction)]))) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)])))) (define/public (on-scroll e) (void)) - (def/public-unimplemented scroll) + (define/public (scroll x y) + (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) + (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) + (when auto-scroll? (refresh-for-autoscroll))) + (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0)) + (set-box! yb (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + (define/public (set-resize-corner on?) (void)) - (define/public (get-virtual-size xb yb) (set-box! xb 10) (set-box! yb 10)))) + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index bb31608e..5beaf40d 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -23,7 +23,7 @@ get-client-size window-lock [get-window g_object_get_window]) - (inherit reset-cr) + (inherit reset-cr set-auto-scroll) (define c #f) @@ -47,13 +47,14 @@ (set! c #f) (semaphore-post window-lock))) - (define/public (reset-dc) + (define/public (reset-dc scroll-dx scroll-dy) ;; FIXME: ensure that the dc is not in use (as-entry (lambda () (when c (cairo_destroy c) - (set! c #f))))) + (set! c #f)) + (set-auto-scroll scroll-dx scroll-dy)))) (define/override (get-size) (let-values ([(w h) (get-client-size)]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index b29ba9d1..91678fb0 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -20,6 +20,7 @@ (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) +(define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -62,6 +63,9 @@ (gtk_label_new_with_mnemonic ""))))] [no-show? (memq 'deleted style)]) + (when (string? label) + (gtk_misc_set_alignment (get-gtk) 0.0 0.0)) + (set-auto-size) (define/override (set-label s) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index e5dee91e..5f3ef186 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -287,9 +287,9 @@ The @scheme[h-value] and @scheme[v-value] arguments each specify a fraction of the scrollbar's movement. A @scheme[0.0] value sets the scrollbar to its left/top, while a @scheme[1.0] value sets the scrollbar to its right/bottom. A @scheme[0.5] value sets the scrollbar to its middle. In - general, if the canvas's virtual size is @scheme[v], its client size is - @scheme[c], and @scheme[(> v c)], then scrolling to @scheme[p] - sets the view start to @scheme[(floor (* p (- v c)))]. + general, if the canvas's virtual size is @scheme[_v], its client size is + @scheme[_c], and @scheme[(> _v _c)], then scrolling to @scheme[_p] + sets the view start to @scheme[(floor (* _p (- _v _c)))]. See also @method[canvas% init-auto-scrollbars] and diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 225394a2..c54e7c62 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1,4 +1,3 @@ - #lang scheme/gui (require mzlib/class @@ -1679,7 +1678,7 @@ (get-scroll-pos 'horizontal) (get-scroll-range 'horizontal) (get-scroll-page 'horizontal))] - [dc (get-dc)]) + [dc (get-dc)]) (let-values ([(w h) (get-client-size)] [(w2 h2) (get-virtual-size)] [(x y) (get-view-start)]) From 55f34df7de8ef4d4c1b42fa06b8dce9e6dd35ea6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 14:51:42 -0600 Subject: [PATCH 131/462] fix canvas dc size reporting original commit: b69d4322afd417c9b354ea3ca0ba2150fe113119 --- collects/mred/private/wx/cocoa/canvas.rkt | 7 ++++++- collects/mred/private/wx/cocoa/dc.rkt | 8 +++++--- collects/mred/private/wx/gtk/canvas.rkt | 2 +- collects/tests/gracket/draw.rkt | 8 ++++---- 4 files changed, 16 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 8908dd79..701221f3 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -226,7 +226,12 @@ (tellv content-cocoa setDelegate: content-cocoa) (install-control-font content-cocoa #f)) - (define dc (make-object dc% (make-graphics-context) 0 0 10 10)) + (define dc (make-object dc% (make-graphics-context) 0 0 10 10 + (lambda () + (let ([w (box 0)] + [h (box 0)]) + (get-virtual-size w h) + (values (unbox w) (unbox h)))))) (queue-paint) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 9c738213..ab7eb832 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -30,7 +30,7 @@ (define dc-backend% (class* default-dc-backend% (dc-backend<%>) - (init context dx dy width height) + (init context dx dy width height -get-virtual-size) (super-new) (inherit reset-cr set-auto-scroll) @@ -79,9 +79,11 @@ (set-bounds dx dy width height) (reset-cr cr)) + (define get-virtual-size -get-virtual-size) (def/override (get-size) - (values (exact->inexact clip-width) - (exact->inexact clip-height))) + (let-values ([(w h) (get-virtual-size)]) + (values (exact->inexact w) + (exact->inexact h)))) (define/override (get-cr) cr) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index c21d443e..16f364bc 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -218,7 +218,7 @@ [get-client-size (lambda () (let ([w (box 0)] [h (box 0)]) - (get-client-size w h) + (get-virtual-size w h) (values (unbox w) (unbox h))))] [window-lock (send (get-top-win) get-dc-lock)] [get-window (lambda (client-gtk) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 381c31c8..8c738956 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -961,12 +961,12 @@ mem-dc) (get-dc)))]) (when dc - (send dc clear) - - (send dc start-doc "Draw Test") + (send dc start-doc "Draw Test") (send dc start-page) - (send dc set-alpha current-alpha) + (send dc clear) + + (send dc set-alpha current-alpha) (send dc set-rotation current-rotation) (send dc set-initial-matrix (if current-skew? (vector 1 0 0.2 1 3 0) From 1bf7884280885ea2abfd326330557c800ad13d8a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 16:37:49 -0600 Subject: [PATCH 132/462] postscript-dc% interactive and landscape original commit: 16f15b0cad7e3edafe06119c71660e6254f2b1b5 --- collects/mred/private/filedialog.rkt | 4 +++- collects/mred/private/wx/cocoa/item.rkt | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index a3d06564..9babd087 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -52,7 +52,9 @@ (raise-type-error who "list of 2-string lists" filters)) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) - (if (or std? (eq? (system-type) 'unix)) + (if (or std? + #t ; for now, always use the manually constructed dialog + (eq? (system-type) 'unix)) (send (new path-dialog% [put? put?] [dir? dir?] diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 54c3d34c..571295bf 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -27,12 +27,12 @@ (define/public (get-cocoa-control) (get-cocoa)) (define/override (enable on?) - (tellv (get-cocoa) setEnabled: #:type _BOOL on?)) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?)) (define/override (is-window-enabled?) (tell #:type _BOOL (get-cocoa-control) isEnabled)) (define/override (gets-focus?) - (tell #:type _BOOL (get-cocoa) canBecomeKeyView)) + (tell #:type _BOOL (get-cocoa-control) canBecomeKeyView)) (define/public (command e) (callback this e)) From 4995e89a214db7f38a73dba3c29cae0a705a68f4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Aug 2010 17:13:54 -0600 Subject: [PATCH 133/462] finix initial size of cocoa frame original commit: ca29be4eb132bf17dfe552aa78981c1f3115b9c1 --- collects/mred/private/wx/cocoa/frame.rkt | 57 +++++++++++++----------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 31f08de8..d21ed049 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -101,31 +101,38 @@ (let ([is-sheet? (and #f is-dialog? parent - (not (send parent frame-is-dialog?)))]) - (as-objc-allocation - (tell (tell (if is-sheet? - MyPanel - MyWindow) - alloc) - initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) - (make-NSRect (make-NSPoint x y) - (make-NSSize (max 30 w) - (max 0 h)))) - styleMask: #:type _int (if (memq 'no-caption style) - NSBorderlessWindowMask - (bitwise-ior - NSTitledWindowMask - (if is-sheet? NSUtilityWindowMask 0) - (if is-dialog? - 0 - (bitwise-ior - NSClosableWindowMask - NSMiniaturizableWindowMask - (if (memq 'no-resize-border style) - 0 - NSResizableWindowMask))))) - backing: #:type _int NSBackingStoreBuffered - defer: #:type _BOOL NO)))] + (not (send parent frame-is-dialog?)))] + [init-rect (let-values ([(x y) (init-pos x y)]) + (make-NSRect (make-NSPoint x y) + (make-NSSize (max 30 w) + (max (if (memq 'no-caption style) + 0 + 22) + h))))]) + (let ([c (as-objc-allocation + (tell (tell (if is-sheet? + MyPanel + MyWindow) + alloc) + initWithContentRect: #:type _NSRect init-rect + styleMask: #:type _int (if (memq 'no-caption style) + NSBorderlessWindowMask + (bitwise-ior + NSTitledWindowMask + (if is-sheet? NSUtilityWindowMask 0) + (if is-dialog? + 0 + (bitwise-ior + NSClosableWindowMask + NSMiniaturizableWindowMask + (if (memq 'no-resize-border style) + 0 + NSResizableWindowMask))))) + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))]) + ;; use init rect as frame size, not content size + (tellv c setFrame: #:type _NSRect init-rect display: #:type _BOOL #f) + c))] [no-show? #t]) (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) From 26dd281012b1381f695a86bbe079ed4e4794f302 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 11:06:02 -0600 Subject: [PATCH 134/462] manual font substitution for Mac OS X original commit: ff57455150f99ea87ce4702acc284e4be119145d --- collects/mred/private/fontdialog.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 9e58232e..5ba477a5 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -52,7 +52,9 @@ [sip (make-object check-box% "Size in Pixels" p4 refresh-sample)] [sym (make-object check-box% "Map as Symbol" p4 refresh-sample)] [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)] - [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))] + [sample (make-object text-field% "Sample" f void + "The quick brown fox jumped over the lazy dog\n(\u3bb (x) x)\n" + '(multiple))] [edit (send sample get-editor)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [get-font (lambda () (let ([face (send face get-string-selection)]) From 992d32134c9696bc24c0227f7c2d7c7fec3a03dc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 19:39:43 -0600 Subject: [PATCH 135/462] enforce modality; more on-subwindow- callbacks; Cocoa font tweaks original commit: e9e180847a72ba91ea817fc3b5fc1a457e676747 --- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 61 +++++++++++++------ .../mred/private/wx/cocoa/group-panel.rkt | 6 +- collects/mred/private/wx/cocoa/list-box.rkt | 1 + collects/mred/private/wx/cocoa/message.rkt | 21 +++++-- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/slider.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 7 +++ collects/mred/private/wx/common/queue.rkt | 13 ++++ collects/mred/private/wx/gtk/choice.rkt | 2 + collects/mred/private/wx/gtk/dialog.rkt | 17 ++++++ collects/mred/private/wx/gtk/frame.rkt | 21 ++++--- collects/mred/private/wx/gtk/menu-bar.rkt | 17 ++++++ collects/mred/private/wx/gtk/tab-panel.rkt | 2 + collects/mred/private/wx/gtk/window.rkt | 8 ++- 17 files changed, 146 insertions(+), 39 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index f6dd2c72..5cf3a558 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -24,7 +24,7 @@ (define MIN-BUTTON-WIDTH 72) (define-objc-class MyButton NSButton - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 98b1f869..e94fc82b 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -19,7 +19,7 @@ (import-class NSPopUpButton) (define-objc-class MyPopUpButton NSPopUpButton - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index d21ed049..81b5f05b 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -27,16 +27,20 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) +(define dialog-level-counter 0) + (define-objc-mixin (MyWindowMethods Superclass) [wx] [-a _scheme (getEventspace) (send wx get-eventspace)] - [-a _BOOL (canBecomeKeyWindow) #t] + [-a _BOOL (canBecomeKeyWindow) + (not (other-modal? wx))] [-a _BOOL (canBecomeMainWindow) #t] [-a _BOOL (windowShouldClose: [_id win]) (queue-window-event wx (lambda () - (when (send wx on-close) - (send wx direct-show #f)))) + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f))))) #f] [-a _void (windowDidResize: [_id notification]) (when wx @@ -149,7 +153,21 @@ (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) (define is-a-dialog? is-dialog?) + (define dialog-level 0) (define/public (frame-is-dialog?) is-a-dialog?) + (define/public (frame-relative-dialog-status win) + ;; called in event-pump thread + (cond + [is-a-dialog? (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))] + [else #f])) + + (define/override (get-dialog-level) + ;; called in event-pump thread + dialog-level) (define/public (clean-up) ;; When a window is resized, then any drawing that is in flight @@ -171,25 +189,32 @@ (set! front #f) (send empty-mb install)) (if on? - (if (and is-a-dialog? - (let ([p (get-parent)]) - (and p - (not (send p get-sheet))))) - (let ([p (get-parent)]) - (send p set-sheet this) - (tell (tell NSApplication sharedApplication) - beginSheet: cocoa - modalForWindow: (send p get-cocoa) - modalDelegate: #f - didEndSelector: #:type _SEL #f - contextInfo: #f)) - (tellv cocoa makeKeyAndOrderFront: #f)) (begin (when is-a-dialog? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (not (send p get-sheet))))) + (let ([p (get-parent)]) + (send p set-sheet this) + (tell (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) + (tellv cocoa makeKeyAndOrderFront: #f))) + (begin + (when is-a-dialog? + (set! dialog-level 0) (let ([p (get-parent)]) (when (and p (eq? this (send p get-sheet))) - (send p set-sheet #f)))) + (send p set-sheet #f) + (tell (tell NSApplication sharedApplication) + endSheet: cocoa)))) (tellv cocoa orderOut: #f) (let ([next (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] @@ -316,7 +341,7 @@ (define/public (set-modified on?) ;; Use standardWindowButton: ... (void)) - + (define/public (create-status-line) (void)) (define/public (set-status-text s) (void)) (def/public-unimplemented status-line-exists?) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index ef1c4200..73588a0a 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -14,6 +14,10 @@ (import-class NSBox) +(define-objc-class MyBox NSBox + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + (defclass group-panel% (panel-mixin window%) (init parent x y w h @@ -24,7 +28,7 @@ (super-new [parent parent] [cocoa (let ([cocoa (as-objc-allocation - (tell (tell NSBox alloc) init))]) + (tell (tell MyBox alloc) init))]) (when label (tellv cocoa setTitle: #:type _NSString label) (tellv cocoa sizeToFit)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index c02bc1c0..7fda6f6e 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -22,6 +22,7 @@ (import-protocol NSTableViewDataSource) (define-objc-class MyTableView NSTableView + #:mixins (FocusResponder KeyMouseResponder) [wx] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))] diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 6a09103f..68d5cc44 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -4,10 +4,11 @@ ffi/objc racket/draw/bitmap "../../syntax.rkt" - "item.rkt" - "utils.rkt" - "types.rkt" - "image.rkt") + "window.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "image.rkt") (unsafe!) (objc-unsafe!) @@ -30,6 +31,14 @@ #:type _NSString "NSApplicationPath"))) +(define-objc-class MyTextField NSTextField + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + +(define-objc-class MyImageView NSImageView + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + (defclass message% item% (init parent label x y @@ -59,9 +68,9 @@ [cocoa (if (string? label) (as-objc-allocation - (tell (tell NSTextField alloc) init)) + (tell (tell MyTextField alloc) init)) (as-objc-allocation - (tell (tell NSImageView alloc) init)))]) + (tell (tell MyImageView alloc) init)))]) (cond [(string? label) (init-font cocoa font) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 6edf6fd0..211410e6 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -24,7 +24,7 @@ (define NSListModeMatrix 2) (define-objc-class MyMatrix NSMatrix - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 679f42bd..c0a8e780 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -22,7 +22,7 @@ (import-class NSSlider) (define-objc-class MySlider NSSlider - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (changed: [_id sender]) (queue-window-event wx (lambda () (send wx changed))) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 3548c163..175e4d40 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -18,6 +18,7 @@ (import-protocol NSTabViewDelegate) (define-objc-class MyTabView NSTabView + #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSTabViewDelegate) [wx] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 7cd2f75a..81d09aac 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -8,6 +8,7 @@ "types.rkt" "keycode.rkt" "../common/event.rkt" + "../common/queue.rkt" "../../syntax.rkt" "../common/freeze.rkt") (unsafe!) @@ -180,6 +181,10 @@ (define/public (get-cocoa-window) (send parent get-cocoa-window)) (define/public (get-wx-window) (send parent get-wx-window)) + (define/public (get-dialog-level) + ;; called in event-pump thread + (send parent get-dialog-level)) + (define/public (make-graphics-context) (and parent (send parent make-graphics-context))) @@ -294,11 +299,13 @@ (define/public (dispatch-on-char e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-event this e) #t] [just-pre? #f] [else (when enabled? (on-event e)) #t])) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index d6b4309b..c50a3371 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe racket/draw/utils ffi/unsafe/atomic + racket/class "rbtree.rkt" "../../lock.rkt" "handlers.rkt") @@ -35,6 +36,7 @@ register-frame-shown get-top-level-windows + other-modal? queue-quit-event) @@ -329,9 +331,20 @@ 'frame-remove))) (define (get-top-level-windows) + ;; called in event-pump thread (hash-map (eventspace-frames-hash (current-eventspace)) (lambda (k v) k))) +(define (other-modal? win) + ;; called in event-pump thread + (let loop ([frames (get-top-level-windows)]) + (and (pair? frames) + (let ([status (send (car frames) frame-relative-dialog-status win)]) + (case status + [(#f) (loop (cdr frames))] + [(same) #f] + [(other) #t]))))) + (define (queue-quit-event) ;; called in event-pump thread (queue-event main-eventspace (application-quit-handler) 'med)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ccd5c549..ff7c532c 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -62,6 +62,8 @@ [callback cb] [no-show? (memq 'deleted style)]) + (connect-key-and-mouse button-gtk) + (gtk_combo_box_set_active gtk 0) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index eee9934b..5cf001f8 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -18,6 +18,8 @@ (define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) +(define dialog-level-counter 0) + (defclass dialog% frame% (inherit get-gtk get-parent) @@ -32,7 +34,22 @@ (when p (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) + (define dialog-level 0) + (define/override (get-dialog-level) dialog-level) + + (define/override (frame-relative-dialog-status win) + (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))) + (define/override (direct-show on?) + (when on? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (unless on? + (set! dialog-level 0)) (unless on? (when close-sema (semaphore-post close-sema) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 06e8ee90..ec99970b 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -52,14 +52,14 @@ (define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void)) -(define (handle-delete gtk) - (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () - (when (send wx on-close) - (send wx direct-show #f)))))) -(define handle_delete - (function-ptr handle-delete - (_fun #:atomic? #t _GtkWidget -> _gboolean))) +(define-signal-handler connect-delete "delete-event" + (_fun _GtkWidget -> _gboolean) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f)))))))) (define-signal-handler connect-configure "configure-event" (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) @@ -121,7 +121,7 @@ (set-size x y w h) - (g_signal_connect gtk "delete_event" handle_delete) + (connect-delete gtk) (connect-configure gtk) (when label @@ -159,6 +159,9 @@ (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) (define/public (get-dc-lock) dc-lock) + (define/override (get-dialog-level) 0) + (define/public (frame-relative-dialog-status win) #f) + (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 0f371ad8..3e086852 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -3,6 +3,7 @@ scheme/foreign "../../syntax.rkt" "../common/freeze.rkt" + "../common/queue.rkt" "widget.rkt" "utils.rkt" "types.rkt") @@ -49,7 +50,17 @@ (define/public (get-top-window) (send parent get-top-window)) (super-new))) +(define-signal-handler connect-menu-key-press "key-press-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (other-modal? wx)))) +(define-signal-handler connect-menu-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (other-modal? wx)))) (defclass menu-bar% widget% (define menus null) @@ -59,12 +70,18 @@ (define/public (get-gtk) gtk) + (connect-menu-key-press gtk) + (connect-menu-button-press gtk) + (define top-wx #f) (define/public (set-top-window top) (set! top-wx top)) (define/public (get-top-window) top-wx) + (define/public (get-dialog-level) + (send top-wx get-dialog-level)) + (define/public (set-label-top pos str) (let ([l (list-ref menus pos)]) (let ([item-gtk (car l)]) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 5ff4a204..ab06e85d 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -86,6 +86,8 @@ [extra-gtks (list client-gtk)] [no-show? (memq 'deleted style)]) + (connect-key-and-mouse gtk) + (set-auto-size) (define callback void) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 42782028..0fb3fab9 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -5,6 +5,7 @@ "../../syntax.rkt" "../common/event.rkt" "../common/freeze.rkt" + "../common/queue.rkt" "keycode.rkt" "queue.rkt" "utils.rkt" @@ -107,7 +108,8 @@ (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) (unless (gtk_widget_is_focus gtk) - (gtk_widget_grab_focus gtk)) + (unless (other-modal? (gtk->wx gtk)) + (gtk_widget_grab_focus gtk))) (do-button-event gtk event #f #f))) (define-signal-handler connect-button-release "button-release-event" @@ -335,6 +337,8 @@ (define/public (get-top-win) (send parent get-top-win)) + (define/public (get-dialog-level) (send parent get-dialog-level)) + (define/public (get-size xb yb) (set-box! xb save-w) (set-box! yb save-h)) @@ -365,11 +369,13 @@ (define/public (handles-events?) #f) (define/public (dispatch-on-char e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-event this e) #t] [just-pre? #f] [else (when enabled? (on-event e)) #t])) From afee071c5c5e52d230df8721da403172d25badba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 20:18:31 -0600 Subject: [PATCH 136/462] fix cocoa pref menu original commit: dedba7a441ea2b3e71700a149c0b913f91a1af0f --- collects/mred/private/wx/cocoa/canvas.rkt | 5 +---- collects/mred/private/wx/cocoa/menu-bar.rkt | 8 +++++--- collects/mred/private/wx/cocoa/queue.rkt | 10 ++++++++-- collects/mred/private/wx/common/event.rkt | 3 +-- collects/mred/private/wx/common/handlers.rkt | 11 ++++++++--- collects/mred/private/wx/common/queue.rkt | 7 ++++++- 6 files changed, 29 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 701221f3..f7a149b0 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -163,8 +163,6 @@ (tellv cocoa setFocusState: #:type _BOOL on?) (tellv cocoa setNeedsDisplay: #:type _BOOL #t))) - (define is-visible? #f) - ;; Avoid multiple queued paints: (define paint-queued? #f) ;; To handle paint requests that happen while on-paint @@ -178,7 +176,7 @@ (set! paint-queued? #t) (queue-window-event this (lambda () (set! paint-queued? #f) - (when is-visible? + (when (is-shown-to-root?) (set! now-drawing? #t) (fix-dc) (on-paint) @@ -268,7 +266,6 @@ (define tr 0) (define/override (show on?) - (set! is-visible? on?) ;; FIXME: what if we're in the middle of an on-paint? (super show on?)) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index aa35cc65..fde29bc7 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -72,18 +72,20 @@ (tellv mb addItem: item) (tellv item release)))]) (let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")]) - (let ([std (lambda (title sel [shortcut ""] [mods #f]) + (let ([std (lambda (title sel [shortcut ""] [mods #f] [delegate? #f]) (let ([item (tell (tell NSMenuItem alloc) initWithTitle: #:type _NSString title action: #:type _SEL sel keyEquivalent: #:type _NSString shortcut)]) (when mods (tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods)) - (tellv item setTarget: app) + (tellv item setTarget: (if delegate? + (tell app delegate) + app)) (tellv apple addItem: item) (tellv item release)))]) (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) - (std "Preferences..." (selector openPreferences:)) + (std "Preferences..." (selector openPreferences:) "," #f #t) (tellv apple addItem: (tell NSMenuItem separatorItem)) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) (tellv app setServicesMenu: services) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 0be2bbcf..57b8fc68 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -7,6 +7,7 @@ "const.rkt" "types.rkt" "../common/queue.rkt" + "../common/handlers.rkt" "../../lock.rkt" "../common/freeze.rkt") (unsafe!) @@ -37,8 +38,13 @@ (queue-quit-event) 0] [-a _BOOL (openPreferences: [_id app]) - (log-error "prefs") - #t]) + (queue-prefs-event) + #t] + [-a _BOOL (validateMenuItem: [_id menuItem]) + (if (ptr-equal? (selector openPreferences:) + (tell #:type _SEL menuItem action)) + (not (eq? (application-pref-handler) nothing-application-pref-handler)) + (super-tell #:type _BOOL validateMenuItem: menuItem))]) (tellv app finishLaunching) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index 36ff6e78..acfcf085 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -91,8 +91,7 @@ (init-properties [[(symbol-in button check-box choice list-box list-box-dclick text-field text-field-enter slider radio-box - menu-popdown menu-popdown-none tab-panel - menu) + menu-popdown menu-popdown-none tab-panel) event-type] ;; FIXME: should have no default 'button]) diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt index 3d8543ee..e8048f0f 100644 --- a/collects/mred/private/wx/common/handlers.rkt +++ b/collects/mred/private/wx/common/handlers.rkt @@ -3,26 +3,31 @@ (provide application-file-handler application-quit-handler application-about-handler - application-pref-handler) + application-pref-handler + + nothing-application-pref-handler) (define afh void) (define application-file-handler (case-lambda [(proc) (set! afh proc)] [() afh])) + (define aqh void) (define application-quit-handler (case-lambda [(proc) (set! aqh proc)] [() aqh])) + (define aah void) (define application-about-handler (case-lambda [(proc) (set! aah proc)] [() aah])) -(define aph void) + +(define (nothing-application-pref-handler) (void)) +(define aph nothing-application-pref-handler) (define application-pref-handler (case-lambda [(proc) (set! aph proc)] [() aph])) - diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index c50a3371..2cdbf09d 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -38,7 +38,8 @@ get-top-level-windows other-modal? - queue-quit-event) + queue-quit-event + queue-prefs-event) ;; ------------------------------------------------------------ ;; This module must be instantiated only once: @@ -348,3 +349,7 @@ (define (queue-quit-event) ;; called in event-pump thread (queue-event main-eventspace (application-quit-handler) 'med)) + +(define (queue-prefs-event) + ;; called in event-pump thread + (queue-event main-eventspace (application-pref-handler) 'med)) From 21ccccbc3f7fb6ba73762204334a14b15a0ec54a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 05:48:18 -0600 Subject: [PATCH 137/462] fix on-subwindow- and modal for choice%; suppress other callbacks on set original commit: f8ba0a65d2104139bc2ab9b072d6e09f5a8aee5b --- collects/mred/private/wx/gtk/canvas.rkt | 51 ++++++---- collects/mred/private/wx/gtk/choice.rkt | 34 +++---- collects/mred/private/wx/gtk/combo.rkt | 118 ++++++++++++++++++++++ collects/mred/private/wx/gtk/list-box.rkt | 75 +++++++++----- collects/mred/private/wx/gtk/slider.rkt | 23 +++-- collects/mred/private/wx/gtk/utils.rkt | 11 +- collects/mred/private/wx/gtk/window.rkt | 11 +- 7 files changed, 234 insertions(+), 89 deletions(-) create mode 100644 collects/mred/private/wx/gtk/combo.rkt diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 16f364bc..36061022 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -12,7 +12,8 @@ "window.rkt" "client-window.rkt" "widget.rkt" - "dc.rkt") + "dc.rkt" + "combo.rkt") (provide canvas%) @@ -108,19 +109,20 @@ (GdkRectangle-height r))) (gdk_gc_unref gc))))) -(define (handle-value-changed-h gtk ignored) - (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx do-scroll 'horizontal)))) - #t) -(define handle_value_changed_h - (function-ptr handle-value-changed-h (_fun #:atomic? #t _GtkWidget _pointer -> _void))) +(define-signal-handler connect-value-changed-h "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'horizontal))) -(define (handle-value-changed-v gtk ignored) +(define-signal-handler connect-value-changed-v "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'vertical))) + +(define (do-value-changed gtk dir) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx do-scroll 'vertical)))) + (queue-window-event wx (lambda () (send wx do-scroll dir)))) #t) -(define handle_value_changed_v - (function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void))) (define-gtk gtk_entry_get_type (_fun -> _GType)) @@ -145,7 +147,9 @@ (define virtual-height #f) (define virtual-width #f) - (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) + (define-values (client-gtk gtk + hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box + combo-button-gtk) (cond [(or (memq 'hscroll style) (memq 'vscroll style)) @@ -184,11 +188,12 @@ (values client-gtk h hadj vadj (and (memq 'hscroll style) h2) (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box))))] + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f)))] [is-combo? (let* ([gtk (gtk_combo_box_entry_new_text)] [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f))] + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] [has-border? (let ([client-gtk (gtk_drawing_area_new)] [h (gtk_hbox_new #f 0)]) @@ -196,10 +201,10 @@ (gtk_container_set_border_width h margin) (connect-expose-border h) (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f))] + (values client-gtk h #f #f #f #f #f #f))] [else (let ([client-gtk (gtk_drawing_area_new)]) - (values client-gtk client-gtk #f #f #f #f #f))])) + (values client-gtk client-gtk #f #f #f #f #f #f))])) (super-new [parent parent] [gtk gtk] @@ -209,7 +214,9 @@ null (if hscroll-adj (list client-gtk hscroll-adj vscroll-adj) - (list client-gtk)))]) + (if combo-button-gtk + (list client-gtk combo-button-gtk) + (list client-gtk))))]) (set-size x y w h) @@ -248,18 +255,18 @@ GDK_LEAVE_NOTIFY_MASK)) (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) GTK_CAN_FOCUS)) + (when combo-button-gtk + (connect-combo-key-and-mouse combo-button-gtk)) - (when hscroll-adj - (g_signal_connect hscroll-adj "value-changed" handle_value_changed_h)) - (when vscroll-adj - (g_signal_connect vscroll-adj "value-changed" handle_value_changed_v)) + (when hscroll-adj (connect-value-changed-h hscroll-adj)) + (when vscroll-adj (connect-value-changed-v vscroll-adj)) (define/override (direct-update?) #f) (define/public (get-dc) dc) (define/override (get-client-gtk) client-gtk) - (define/override (handles-events?) #t) + (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ff7c532c..ce69a648 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -7,7 +7,9 @@ "types.rkt" "utils.rkt" "window.rkt" - "../common/event.rkt") + "combo.rkt" + "../common/event.rkt" + "../common/queue.rkt") (unsafe!) (provide choice%) @@ -20,9 +22,6 @@ (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) -(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) -(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) - (define-signal-handler connect-changed "changed" (_fun _GtkWidget -> _void) (lambda (gtk) @@ -43,18 +42,7 @@ ;; Hack to access the combobox's private child, where is ;; where the keyboard focus goes. - (define button-gtk - (let ([all null] - [ext null]) - (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) - (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) - (for-each (lambda (e) - (set! all (filter (lambda (a) (not (ptr-equal? a e))) - all))) - ext) - (unless (= 1 (length all)) - (error "expected Gtk combobox to have one private child")) - (car all))) + (define button-gtk (extract-combo-button gtk)) (super-new [parent parent] [gtk gtk] @@ -62,14 +50,13 @@ [callback cb] [no-show? (memq 'deleted style)]) - (connect-key-and-mouse button-gtk) - (gtk_combo_box_set_active gtk 0) (set-auto-size) (connect-changed gtk) (connect-focus button-gtk) + (connect-combo-key-and-mouse button-gtk) (define callback cb) (define/public (clicked) @@ -94,13 +81,18 @@ (define/public (clear) (as-entry (lambda () + (set! ignore-clicked? #t) (for ([i (in-range count)]) (gtk_combo_box_remove_text gtk 0)) - (set! count 0)))) - (define/public (append l) + (set! count 0) + (set! ignore-clicked? #f)))) + (public [-append append]) + (define (-append l) (as-entry (lambda () + (set! ignore-clicked? #t) (set! count (add1 count)) (gtk_combo_box_append_text gtk l) (when (= count 1) - (set-selection 0)))))) + (set-selection 0)) + (set! ignore-clicked? #f))))) diff --git a/collects/mred/private/wx/gtk/combo.rkt b/collects/mred/private/wx/gtk/combo.rkt new file mode 100644 index 00000000..d0c08c37 --- /dev/null +++ b/collects/mred/private/wx/gtk/combo.rkt @@ -0,0 +1,118 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt") +(unsafe!) + +;; Hacks for working with GtkComboBox[Entry] + +(provide extract-combo-button + connect-combo-key-and-mouse) + +;; ---------------------------------------- + +(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) +(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) + +(define-gobj g_signal_parse_name (_fun _string + _GType + (id : (_ptr o _uint)) + (_ptr o _GQuark) + _gboolean + -> (r : _gboolean) + -> (and r id))) + +(define-gobj g_type_from_name (_fun _string -> _GType)) + +(define _GSignalMatchType _int) +(define _GQuark _uint32) +(define _GClosure _int) +(define-gobj g_signal_handler_find (_fun _GtkWidget + _GSignalMatchType + _uint ; signal_id + _GQuark ; detail + _GClosure ; closure + _pointer ; func + _pointer ; data + -> _ulong)) +(define-gobj g_signal_handler_disconnect (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_block (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_unblock (_fun _GtkWidget _uint -> _void)) + +(define-gobj g_signal_emit (_fun _GtkWidget + _uint + _GQuark + _pointer + (r : (_ptr o _gboolean)) + -> _void + -> r)) + +(define G_SIGNAL_MATCH_ID 1) + +(define button-press-id #f) + +(define unblocked? #f) +(define-signal-handler connect-reorder-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer _long -> _gboolean) + (lambda (gtk event other-id) + (if unblocked? + #f + (let ([v (do-button-event gtk event #f #f)]) + (or v + (begin + (g_signal_handler_unblock gtk other-id) + (let ([r (g_signal_emit gtk + button-press-id + 0 + event)]) + (g_signal_handler_block gtk other-id) + r))))))) + +;; Dependence on the implemenation of GtkComboBox: +;; Keyboard focus and other actions are based on a private button widget +;; inside a GtkComboBox, so we extract it. +(define (extract-combo-button gtk) + (let ([all null] + [ext null]) + (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) + (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) + (for-each (lambda (e) + (set! all (filter (lambda (a) (not (ptr-equal? a e))) + all))) + ext) + (unless (= 1 (length all)) + (error "expected Gtk combobox to have one private child")) + (car all))) + +;; More dependence on the implemenation of GtkComboBox: +;; The memnu-popup action is implemented by seeting a button-press-event +;; signal handler on `button-gtk'. Since Gtk calls signal handlers in the +;; order that they're registered, our button-press-event handler doesn't +;; get called first, so it can't cancel the button press due to modality +;; or an `on-subwindow-event' result. We effectively reorder the callbacks +;; by finding the old one, blocking it, and then unblocking during a +;; redispatch. +(define (connect-combo-key-and-mouse button-gtk) + (unless button-press-id + (set! button-press-id + (g_signal_parse_name "button-press-event" (g_type_from_name "GtkWidget") #f))) + (let ([hand-id + (and button-press-id + (let ([hand-id (g_signal_handler_find button-gtk + G_SIGNAL_MATCH_ID + button-press-id + 0 + 0 + #f + #f)]) + (if (zero? hand-id) + #f + (begin + (g_signal_handler_block button-gtk hand-id) + hand-id))))]) + (connect-key-and-mouse button-gtk (and hand-id #t)) + (when hand-id + (connect-reorder-button-press button-gtk (cast hand-id _long _pointer))))) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index a744d4ae..4544f778 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -79,9 +79,14 @@ (let ([iter (make-GtkTreeIter 0 #f #f #f)]) (for ([s (in-list items)]) (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1)))) - (reset-content) + (gtk_list_store_set store iter 0 s -1))) + (maybe-init-select)) + (define/private (maybe-init-select) + (when (and (= (get-selection) -1) + (pair? data)) + (set-selection 0))) + (define column (let ([renderer (gtk_cell_renderer_text_new)]) (gtk_tree_view_column_new_with_attributes @@ -119,15 +124,18 @@ (define/override (get-client-gtk) client-gtk) (define callback cb) + (define ignore-click? #f) (define/public (queue-changed) + (make-will-executor) ;; Called from event-handling thread - (queue-window-event - this - (lambda () - (unless (null? items) - (callback this (new control-event% - [event-type 'list-box] - [time-stamp (current-milliseconds)])))))) + (unless ignore-click? + (queue-window-event + this + (lambda () + (unless (null? items) + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)]))))))) (define/private (get-iter i) (let ([iter (make-GtkTreeIter 0 #f #f #f)] @@ -151,10 +159,14 @@ (gtk_tree_path_free p))) (define/public (set choices) - (clear) - (set! items choices) - (set! data (map (lambda (x) (box #f)) choices)) - (reset-content)) + (as-entry + (lambda () + (set! ignore-click? #t) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content) + (set! ignore-click? #f)))) (define/public (get-selections) (as-entry @@ -206,14 +218,18 @@ (gtk_tree_path_free p)))) (define/public (select i [on? #t] [extend? #t]) - (let ([p (gtk_tree_path_new_from_indices i -1)]) - (if on? - (begin - (unless extend? - (gtk_tree_selection_unselect_all selection)) - (gtk_tree_selection_select_path selection p)) - (gtk_tree_selection_unselect_path selection p)) - (gtk_tree_path_free p))) + (as-entry + (lambda () + (set! ignore-click? #t) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p)) + (set! ignore-click? #f)))) (define/public (set-selection i) (select i #t #f)) @@ -231,10 +247,15 @@ (public [append* append]) (define (append* s [v #f]) - (set! items (append items (list s))) - (set! data (append data (list (box v)))) - (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1)))) - + (as-entry + (lambda () + (set! ignore-click? #t) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)) + (maybe-init-select) + (set! ignore-click? #f)))) + (reset-content)) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 3a273718..2ed4cc2e 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -7,7 +7,8 @@ "types.rkt" "window.rkt" "const.rkt" - "../common/event.rkt") + "../common/event.rkt" + "../../lock.rkt") (unsafe!) (provide slider%) @@ -53,17 +54,23 @@ (connect-changed gtk) (define callback cb) + (define ignore-click? #f) (define/public (queue-changed) ;; Called in event-dispatch thread (gtk_range_set_value gtk (floor (gtk_range_get_value gtk))) - (queue-window-event - this - (lambda () - (callback this (new control-event% - [event-type 'slider] - [time-stamp (current-milliseconds)]))))) + (unless ignore-click? + (queue-window-event + this + (lambda () + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)])))))) (define/public (set-value v) - (gtk_range_set_value gtk v)) + (as-entry + (lambda () + (set! ignore-click? #t) + (gtk_range_set_value gtk v) + (set! ignore-click? #f)))) (define/public (get-value) (inexact->exact (floor (gtk_range_get_value gtk))))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 9175c90f..5524e577 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -17,7 +17,6 @@ g_object_set_data g_object_get_data - g_signal_connect g_object_new @@ -81,9 +80,9 @@ (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) -(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer (_pointer = #f) _fnpointer _int -> _ulong)) -(define (g_signal_connect obj s proc) - (g_signal_connect_data obj s proc #f 0)) +(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong)) +(define (g_signal_connect obj s proc user-data) + (g_signal_connect_data obj s proc user-data #f 0)) (define-gobj g_object_get (_fun _GtkWidget (_string = "window") [w : (_ptr o _GdkWindow)] @@ -114,5 +113,5 @@ (define handler-proc proc) (define handler_function (function-ptr handler-proc (_fun #:atomic? #t . args))) - (define (connect-name gtk) - (g_signal_connect gtk signal-name handler_function)))) + (define (connect-name gtk [user-data #f]) + (g_signal_connect gtk signal-name handler_function user-data)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 0fb3fab9..b24e6537 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -29,6 +29,7 @@ connect-focus connect-key-and-mouse + do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer (struct-out GtkAllocation) _GtkAllocation-pointer) @@ -96,7 +97,7 @@ [y 0] [time-stamp (GdkEventKey-time event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events?) + (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) #t) @@ -132,10 +133,10 @@ (lambda (gtk event) (do-button-event gtk event #f #t))) -(define (connect-key-and-mouse gtk) +(define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) (connect-button-press gtk) - (connect-button-release gtk) + (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) (connect-enter gtk) (connect-leave gtk)) @@ -201,7 +202,7 @@ (if crossing? GdkEventCrossing-time GdkEventButton-time)) event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events?) + (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () (send wx dispatch-on-event m #f))) @@ -366,7 +367,7 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) - (define/public (handles-events?) #f) + (define/public (handles-events? gtk) #f) (define/public (dispatch-on-char e just-pre?) (cond [(other-modal? this) #t] From 1ef742fd91193e78c3ee5d16fa3b246fc3395490 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 07:18:28 -0600 Subject: [PATCH 138/462] fix cocoa menu-bar set menu label original commit: a4c036b50acafe302732a30784f314d858c88e3c --- collects/mred/private/wx/cocoa/menu-bar.rkt | 23 ++++++++++++++------- collects/mred/private/wx/cocoa/menu.rkt | 13 +++++------- collects/mred/private/wx/cocoa/utils.rkt | 6 +++++- 3 files changed, 26 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index fde29bc7..1ca3d147 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -1,14 +1,13 @@ #lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +(require racket/class + ffi/unsafe + ffi/unsafe/objc + (only-in racket/list take drop) "../../syntax.rkt" "utils.rkt" "types.rkt" "const.rkt" "queue.rkt") -(unsafe!) -(objc-unsafe!) (provide menu-bar%) @@ -113,7 +112,6 @@ (defclass menu-bar% object% (define menus null) - (def/public-unimplemented set-label-top) (def/public-unimplemented number) (def/public-unimplemented enable-top) @@ -130,7 +128,9 @@ (public [append-menu append]) (define (append-menu menu title) (set! menus (append menus (list (cons menu title)))) - (send menu set-parent this)) + (send menu set-parent this) + (when (eq? current-mb this) + (send menu install cocoa-mb title))) (define/public (install) (let loop () @@ -148,6 +148,15 @@ (define/public (get-top-window) top-wx) + (define/public (set-label-top pos str) + (set! menus (append + (take menus pos) + (list (cons (car (list-ref menus pos)) str)) + (drop menus (add1 pos)))) + (when (eq? current-mb this) + (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) + setTitle: #:type _NSString (clean-menu-label str)))) + (define/public (do-on-menu-click) (let ([es (send top-wx get-eventspace)]) (when es diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index ccd37313..2b64cc89 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -17,9 +17,6 @@ (define-struct mitem (item)) -(define (clean-label str) - (regexp-replace* #rx"&(.)" str "\\1")) - (defclass menu% object% (init-field label callback @@ -37,13 +34,13 @@ (set! cocoa (as-objc-allocation (tell (tell NSMenuItem alloc) - initWithTitle: #:type _NSString (clean-label label) + initWithTitle: #:type _NSString (clean-menu-label label) action: #:type _SEL #f keyEquivalent: #:type _NSString ""))) (set! cocoa-menu (as-objc-allocation (tell (tell NSMenu alloc) - initWithTitle: #:type _NSString (clean-label label)))) + initWithTitle: #:type _NSString (clean-menu-label label)))) (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) @@ -137,10 +134,10 @@ (define/public (set-label item label) (adjust item (lambda (item-cocoa) - (tellv item-cocoa setTitle: #:type _NSString (clean-label label))) + (tellv item-cocoa setTitle: #:type _NSString (clean-menu-label label))) (lambda (mitem) - (send (mitem-item mitem) set-label (clean-label label))))) - + (send (mitem-item mitem) set-label (clean-menu-label label))))) + (define/public (check item on?) (adjust item (lambda (item-cocoa) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index aacb4303..132b691f 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -13,7 +13,8 @@ define-mz as-objc-allocation retain release - with-autorelease) + with-autorelease + clean-menu-label) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) @@ -46,3 +47,6 @@ (begin0 (thunk) (release pool)))) + +(define (clean-menu-label str) + (regexp-replace* #rx"&(.)" str "\\1")) From f67eea2b7acf3ac1ea6d97da0b0e5c9a05df530b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 07:44:39 -0600 Subject: [PATCH 139/462] yet more cocoa canvas repairs original commit: f716ae049a730cbc9fc17c974087cce78ababcc1 --- collects/mred/private/wx/cocoa/canvas.rkt | 59 +++++++++++++++++------ collects/mred/private/wx/cocoa/dc.rkt | 4 +- collects/mred/private/wx/cocoa/frame.rkt | 2 + collects/mred/private/wx/cocoa/panel.rkt | 4 ++ collects/mred/private/wx/cocoa/window.rkt | 4 ++ 5 files changed, 57 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index f7a149b0..6d5470bd 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -68,6 +68,28 @@ (CGContextStrokePath cg)) (tellv ctx restoreGraphicsState)))) +(define-objc-class CornerlessFrameView NSView + [] + (-a _void (drawRect: [_NSRect r]) + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [r (tell #:type _NSRect self bounds)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (let* ([l (NSPoint-x (NSRect-origin r))] + [t (NSPoint-y (NSRect-origin r))] + [b (+ t (NSSize-height (NSRect-size r)))] + [r (+ l (NSSize-width (NSRect-size r)))]) + (CGContextAddLines cg + (vector + (make-NSPoint r (+ t scroll-width)) + (make-NSPoint r b) + (make-NSPoint l b) + (make-NSPoint l t) + (make-NSPoint (- r scroll-width) t)))) + (CGContextStrokePath cg)) + (tellv ctx restoreGraphicsState)))) + (define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) (define-cocoa NSRectFill (_fun _NSRect -> _void)) @@ -136,6 +158,7 @@ get-eventspace make-graphics-context is-shown-to-root? + is-shown-to-before-root? move get-x get-y on-size register-as-child @@ -199,7 +222,9 @@ (tell (tell (cond [is-combo? NSView] [(memq 'control-border style) FocusView] - [(memq 'border style) FrameView] + [(memq 'border style) (if (memq 'vscroll style) + CornerlessFrameView + FrameView)] [else NSView]) alloc) initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) @@ -236,19 +261,22 @@ (define/public (get-dc) dc) (define/public (fix-dc) - (let ([p (tell #:type _NSPoint content-cocoa - convertPoint: #:type _NSPoint (make-NSPoint 0 0) - toView: #f)] - [xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (send dc reset-bounds - (+ (NSPoint-x p) (if is-combo? 2 0)) - (- (NSPoint-y p) (if is-combo? 22 0)) - (max 1 (- (unbox xb) (if is-combo? 22 0))) - (unbox yb) - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0)))) + (when (dc . is-a? . dc%) + (if (is-shown-to-before-root?) + (let ([p (tell #:type _NSPoint content-cocoa + convertPoint: #:type _NSPoint (make-NSPoint 0 0) + toView: #f)] + [xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (send dc reset-bounds + (+ (NSPoint-x p) (if is-combo? 2 0)) + (- (NSPoint-y p) (if is-combo? 22 0)) + (max 1 (- (unbox xb) (if is-combo? 22 0))) + (unbox yb) + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0))) + (send dc reset-bounds 0 0 0 0 0 0)))) (define/override (get-client-size xb yb) (super get-client-size xb yb) @@ -267,7 +295,8 @@ (define/override (show on?) ;; FIXME: what if we're in the middle of an on-paint? - (super show on?)) + (super show on?) + (fix-dc)) (define/private (do-set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ab7eb832..dd55ba0d 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -15,7 +15,8 @@ CGContextSetRGBFillColor CGContextFillRect CGContextAddRect - CGContextStrokePath) + CGContextStrokePath + CGContextAddLines) (define _CGContextRef (_cpointer 'CGContextRef)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) @@ -24,6 +25,7 @@ (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) (define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) (define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 81b5f05b..3c843bde 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -240,6 +240,8 @@ (define/override (is-shown-to-root?) (is-shown?)) + (define/override (is-shown-to-before-root?) #t) + (define/override (is-parent-enabled-to-root?) #t) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 0c34141c..84423107 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -44,6 +44,10 @@ (if on? (cons child children) (remq child children)))))) + + (define/override (show on?) + (super show on?) + (fix-dc)) (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 81d09aac..91fbedb1 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -213,6 +213,10 @@ (and (is-shown?) (send parent is-shown-to-root?))) + (define/public (is-shown-to-before-root?) + (and (is-shown?) + (send parent is-shown-to-before-root?))) + (define enabled? #t) (define/public (is-enabled-to-root?) (and (is-window-enabled?) (is-parent-enabled-to-root?))) From 83a6c5076deb203ec596b04cc22308a065546b84 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 11:13:17 -0600 Subject: [PATCH 140/462] eventspace shutdown original commit: 72b671b6659702a9ff38c57b478873f661baffcb --- collects/mred/private/wx/cocoa/frame.rkt | 10 + collects/mred/private/wx/cocoa/window.rkt | 3 + collects/mred/private/wx/common/queue.rkt | 241 ++++++++++++---------- collects/mred/private/wx/gtk/frame.rkt | 16 +- collects/mred/private/wx/gtk/menu-bar.rkt | 5 +- collects/mred/private/wx/gtk/menu.rkt | 8 +- collects/mred/private/wx/gtk/widget.rkt | 14 +- collects/mred/private/wx/gtk/window.rkt | 3 +- 8 files changed, 184 insertions(+), 116 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3c843bde..c8b25782 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -98,6 +98,7 @@ (init [is-dialog? #f]) (inherit get-cocoa get-parent + get-eventspace pre-on-char pre-on-event) (super-new [parent parent] @@ -232,8 +233,17 @@ (register-frame-shown this on?)))) (define/override (show on?) + (when on? + (when (eventspace-shutdown? (get-eventspace)) + (error (string->symbol + (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%))) + "the eventspace hash been shutdown"))) (direct-show on?)) + (define/public (destroy) + (when child-sheet (send child-sheet destroy)) + (direct-show #f)) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 91fbedb1..0f99ecf7 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -169,6 +169,9 @@ (send parent get-eventspace) (current-eventspace))) + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) + (set-ivar! cocoa wx this) (unless no-show? diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2cdbf09d..e05b2423 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -114,7 +114,7 @@ ;; ------------------------------------------------------------ ;; Eventspaces -(define-struct eventspace (handler-thread queue-proc frames-hash done-evt) +(define-struct eventspace (handler-thread queue-proc frames-hash done-evt [shutdown? #:mutable] done-sema) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -138,117 +138,141 @@ [(< am bm) -1] [else 1])))) + +(define-mz scheme_add_managed (_fun _racket ; custodian + _racket ; object + (_fun #:atomic? #t _racket _pointer -> _void) + _pointer ; data + _int ; strong? + -> _pointer)) + +(define (shutdown-eventspace! e ignored-data) + (unless (eventspace-shutdown? e) + (set-eventspace-shutdown?! e #t) + (semaphore-post (eventspace-done-sema e)) + (for ([f (in-list (get-top-level-windows e))]) + (send f destroy)))) + (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] [frames (make-hasheq)]) - (make-eventspace th - (let ([count 0]) - (let ([lo (mcons #f #f)] - [med (mcons #f #f)] - [hi (mcons #f #f)] - [timer (box '())] - [timer-counter 0] - [newly-posted-sema (make-semaphore)]) - (let* ([check-done - (lambda () - (if (or (positive? count) - (positive? (hash-count frames)) - (not (null? (unbox timer)))) - (semaphore-try-wait? done-sema) - (semaphore-post done-sema)))] - [enqueue (lambda (v q) - (set! count (add1 count)) - (check-done) - (let ([p (mcons v #f)]) - (if (mcdr q) - (set-mcdr! (mcdr q) p) - (set-mcar! q p)) - (set-mcdr! q p)))] - [first (lambda (q) - (and (mcar q) - (wrap-evt - always-evt - (lambda (_) - (start-atomic) - (set! count (sub1 count)) - (check-done) - (let ([result (mcar (mcar q))]) - (set-mcar! q (mcdr (mcar q))) - (unless (mcar q) - (set-mcdr! q #f)) - (end-atomic) - result)))))] - [remove-timer - (lambda (v timer) - (set-box! timer (rbtree-remove + (let ([e + (make-eventspace th + (let ([count 0]) + (let ([lo (mcons #f #f)] + [med (mcons #f #f)] + [hi (mcons #f #f)] + [timer (box '())] + [timer-counter 0] + [newly-posted-sema (make-semaphore)]) + (let* ([check-done + (lambda () + (if (or (positive? count) + (positive? (hash-count frames)) + (not (null? (unbox timer)))) + (semaphore-try-wait? done-sema) + (semaphore-post done-sema)))] + [enqueue (lambda (v q) + (set! count (add1 count)) + (check-done) + (let ([p (mcons v #f)]) + (if (mcdr q) + (set-mcdr! (mcdr q) p) + (set-mcar! q p)) + (set-mcdr! q p)))] + [first (lambda (q) + (and (mcar q) + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (set! count (sub1 count)) + (check-done) + (let ([result (mcar (mcar q))]) + (set-mcar! q (mcdr (mcar q))) + (unless (mcar q) + (set-mcdr! q #f)) + (end-atomic) + result)))))] + [remove-timer + (lambda (v timer) + (set-box! timer (rbtree-remove + timed-compare + v + (unbox timer))) + (check-done))]) + (case-lambda + [(v) + ;; Enqueue + (start-atomic) + (let ([val (cdr v)]) + (case (car v) + [(lo) (enqueue val lo)] + [(med) (enqueue val med)] + [(hi) (enqueue val hi)] + [(timer-add) + (set! timer-counter (add1 timer-counter)) + (set-timed-id! val timer-counter) + (set-box! timer + (rbtree-insert timed-compare - v + val (unbox timer))) - (check-done))]) - (case-lambda - [(v) - ;; Enqueue - (start-atomic) - (let ([val (cdr v)]) - (case (car v) - [(lo) (enqueue val lo)] - [(med) (enqueue val med)] - [(hi) (enqueue val hi)] - [(timer-add) - (set! timer-counter (add1 timer-counter)) - (set-timed-id! val timer-counter) - (set-box! timer - (rbtree-insert - timed-compare - val - (unbox timer))) - (check-done)] - [(timer-remove) (remove-timer val timer)] - [(frame-add) (hash-set! frames val #t) (check-done)] - [(frame-remove) (hash-remove! frames val) (check-done)])) - (semaphore-post newly-posted-sema) - (set! newly-posted-sema (make-semaphore)) - (check-done) - (end-atomic)] - [() - ;; Dequeue as evt - (start-atomic) - (let ([timer-first-ready - (lambda (timer) - (let ([rb (unbox timer)]) - (and (not (null? rb)) - (let* ([v (rbtree-min (unbox timer))] - [evt (timed-alarm-evt v)]) - (and (sync/timeout 0 evt) - ;; It's ready + (check-done)] + [(timer-remove) (remove-timer val timer)] + [(frame-add) (hash-set! frames val #t) (check-done)] + [(frame-remove) (hash-remove! frames val) (check-done)])) + (semaphore-post newly-posted-sema) + (set! newly-posted-sema (make-semaphore)) + (check-done) + (end-atomic)] + [() + ;; Dequeue as evt + (start-atomic) + (let ([timer-first-ready + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (let* ([v (rbtree-min (unbox timer))] + [evt (timed-alarm-evt v)]) + (and (sync/timeout 0 evt) + ;; It's ready + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (remove-timer v timer) + (end-atomic) + (timed-val v))))))))] + [timer-first-wait + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) (wrap-evt - always-evt - (lambda (_) - (start-atomic) - (remove-timer v timer) - (end-atomic) - (timed-val v))))))))] - [timer-first-wait - (lambda (timer) - (let ([rb (unbox timer)]) - (and (not (null? rb)) - (wrap-evt - (timed-alarm-evt (rbtree-min (unbox timer))) - (lambda (_) #f)))))]) - (let ([e (choice-evt - (wrap-evt (semaphore-peek-evt newly-posted-sema) - (lambda (_) #f)) - (or (first hi) - (timer-first-ready timer) - (first med) - (first lo) - (timer-first-wait timer) - ;; nothing else ready... - never-evt))]) - (end-atomic) - e))])))) - frames - (semaphore-peek-evt done-sema)))) + (timed-alarm-evt (rbtree-min (unbox timer))) + (lambda (_) #f)))))]) + (let ([e (choice-evt + (wrap-evt (semaphore-peek-evt newly-posted-sema) + (lambda (_) #f)) + (or (first hi) + (timer-first-ready timer) + (first med) + (first lo) + (timer-first-wait timer) + ;; nothing else ready... + never-evt))]) + (end-atomic) + e))])))) + frames + (semaphore-peek-evt done-sema) + #f + done-sema)]) + (scheme_add_managed (current-custodian) + e + shutdown-eventspace! + #f + 1) + e))) (define main-eventspace (make-eventspace* (current-thread))) (define current-eventspace (make-parameter main-eventspace)) @@ -308,7 +332,6 @@ (sync e)]))])) (define event-dispatch-handler (make-parameter void)) -(define (eventspace-shutdown? e) #f) (define (main-eventspace? e) (eq? e main-eventspace)) @@ -331,9 +354,9 @@ 'frame-add 'frame-remove))) -(define (get-top-level-windows) +(define (get-top-level-windows [e (current-eventspace)]) ;; called in event-pump thread - (hash-map (eventspace-frames-hash (current-eventspace)) + (hash-map (eventspace-frames-hash e) (lambda (k v) k))) (define (other-modal? win) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index ec99970b..8e67ae9a 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -97,7 +97,7 @@ (inherit get-gtk set-size on-size pre-on-char pre-on-event get-client-delta get-size - get-parent) + get-parent get-eventspace) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -207,10 +207,24 @@ (set-top-position x y) (gtk_window_resize gtk (max 1 w) (max 1 h))) + (define/override (show on?) + (when (and on? + (eventspace-shutdown? (get-eventspace))) + (error (string->symbol + (format "show method in ~a" + (if (frame-relative-dialog-status this) + 'dialog% + 'frame%))) + "eventspace has been shutdown")) + (super show on?)) + (define/override (direct-show on?) (super direct-show on?) (register-frame-shown this on?)) + (define/public (destroy) + (direct-show #f)) + (define/override (on-client-size w h) (on-size w h)) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 3e086852..20d225e5 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -63,6 +63,8 @@ (other-modal? wx)))) (defclass menu-bar% widget% + (inherit install-widget-parent) + (define menus null) (define gtk (gtk_menu_bar_new)) @@ -75,7 +77,8 @@ (define top-wx #f) (define/public (set-top-window top) - (set! top-wx top)) + (set! top-wx top) + (install-widget-parent top)) (define/public (get-top-window) top-wx) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index f5cf8247..4e2232b6 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -75,6 +75,8 @@ callback font) + (inherit install-widget-parent) + (define cb callback) (define gtk (gtk_menu_new)) @@ -88,7 +90,8 @@ (define parent #f) (define/public (set-parent p) - (set! parent p)) + (set! parent p) + (install-widget-parent p)) (define/public (get-top-parent) ;; Maybe be called in Gtk event-handler thread (and parent @@ -187,7 +190,8 @@ (let ([item (new menu-item-handler% [gtk item-gtk] [menu this] - [menu-item i])]) + [menu-item i] + [parent this])]) (set! items (append items (list (list item item-gtk label chckable?)))) (adjust-shortcut item-gtk label))) (gtk_menu_shell_append gtk item-gtk) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index bb1d602b..c8e8ea54 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -2,6 +2,7 @@ (require scheme/foreign scheme/class "../../syntax.rkt" + "../common/queue.rkt" "queue.rkt" "utils.rkt" "types.rkt") @@ -30,11 +31,20 @@ (define widget% (class object% (init gtk - [extra-gtks null]) - (init-field [eventspace (current-eventspace)]) + [extra-gtks null] + [parent #f]) + (init-field [eventspace (if parent + (send parent get-eventspace) + (current-eventspace))]) + + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) (define/public (get-eventspace) eventspace) (define/public (direct-update?) #t) + + (define/public (install-widget-parent p) + (set! eventspace (send p get-eventspace))) (super-new) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b24e6537..c0f652d8 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -248,7 +248,8 @@ [add-to-parent? #t]) (super-new [gtk gtk] - [extra-gtks extra-gtks]) + [extra-gtks extra-gtks] + [parent parent]) (define save-x 0) (define save-y 0) From 8e0c3afad6f9fb73eb6c2bae7c0f9f526394ddf1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 05:35:12 -0600 Subject: [PATCH 141/462] set up backing-dc% original commit: bb68137829fc896a34838466f7a7f810cac98703 --- .../mred/private/wx/common/backing-dc.rkt | 78 +++++++++++++++++++ 1 file changed, 78 insertions(+) create mode 100644 collects/mred/private/wx/common/backing-dc.rkt diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt new file mode 100644 index 00000000..c8cef0ed --- /dev/null +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -0,0 +1,78 @@ +#lang racket/base +(require racket/class + racket/draw/dc + racket/draw/bitmap-dc + racket/draw/bitmap + racket/draw/local) + +(provide backing-dc% + + ;; scoped method names: + get-backing-size + flush-backing + start-on-paint + end-on-paint) + +(define-local-member-name + get-backing-size + flush-backing + start-on-paint + end-on-paint) + +(define backing-dc% + (class (dc-mixin bitmap-dc-backend%) + (inherit call-with-cr-lock + internal-get-bitmap + internal-set-bitmap) + + (super-new) + + ;; Override this method to get the right size + (define/public (get-backing-size xb yb) + (set-box! xb 1) + (set-box! yb 1)) + + ;; override this method to push the bitmap to + ;; the device that it backs + (define/public (flush-backing bm) + (void)) + + (define on-paint-cr #f) + + (define/public (start-on-paint) + (call-with-cr-lock + (lambda () + (if on-paint-cr + (log-error "nested start-on-paint") + (set! on-paint-cr (get-cr)))))) + + (define/public (end-on-paint) + (call-with-cr-lock + (lambda () + (if (not on-paint-cr) + (log-error "unbalanced end-on-paint") + (let ([cr on-paint-cr]) + (set! on-paint-cr #f) + (release-cr cr)))))) + + (define/override (get-cr) + (or on-paint-cr + (let ([w (box 0)] + [h (box 0)]) + (get-backing-size) + (let ([bm (get-backing-bitmap (unbox w) (unbox h))]) + (internal-set-bitmap bm)) + (super get-cr)))) + + (define/override (release-cr cr) + (unless (eq? cr on-paint-cr) + (let ([bm (internal-get-bitmap)]) + (internal-set-bitmap #f) + (flush-backing bm) + (release-backing-bitmap bm)))))) + +(define (get-backing-bitmap w h) + (make-object bitmap% w h #f #t)) + +(define (release-backing-bitmap bm) + (send bm release-bitma-storage)) From a4eeceff334cc88d083305bab1028d6802b27792 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 11:45:15 -0600 Subject: [PATCH 142/462] new cocoa canvas-refresh strategy original commit: 7a7658e86d209a9de522e72116ba36c3b9466f2d --- collects/mred/private/wx/cocoa/canvas.rkt | 161 +++++++++--------- collects/mred/private/wx/cocoa/dc.rkt | 147 ++++++++-------- collects/mred/private/wx/cocoa/frame.rkt | 26 +++ collects/mred/private/wx/cocoa/queue.rkt | 2 - collects/mred/private/wx/cocoa/window.rkt | 55 +++++- .../mred/private/wx/common/backing-dc.rkt | 102 +++++++---- collects/mred/private/wxme/pasteboard.rkt | 29 ++-- collects/mred/private/wxme/text.rkt | 23 ++- 8 files changed, 329 insertions(+), 216 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 6d5470bd..b6bfe1ea 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -12,6 +12,7 @@ "dc.rkt" "queue.rkt" "item.rkt" + "../common/backing-dc.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -26,26 +27,29 @@ (import-protocol NSComboBoxDelegate) +;; Called when a canvas has no backing store ready +(define (clear-background wx) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState))))) + (define-objc-class MyView NSView #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (drawRect: [_NSRect r]) - (unless (send wx reject-partial-update r) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) + (unless (send wx paint-or-queue-paint) + (clear-background wx) ;; ensure that `nextEventMatchingMask:' returns (post-dummy-event))) (-a _void (viewWillMoveToWindow: [_id w]) @@ -117,24 +121,11 @@ [wx] (-a _void (drawRect: [_NSRect r]) (super-tell #:type _void drawRect: #:type _NSRect r) - (unless (send wx during-menu-click?) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event))) + (unless (send wx paint-or-queue-paint) + (unless (send wx during-menu-click?) + (clear-background wx) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))) (-a _void (comboBoxWillPopUp: [_id notification]) (send wx starting-combo)) (-a _void (comboBoxWillDismiss: [_id notification]) @@ -154,7 +145,7 @@ [ignored-name #f] [gl-config #f]) - (inherit get-cocoa + (inherit get-cocoa get-cocoa-window get-eventspace make-graphics-context is-shown-to-root? @@ -173,55 +164,69 @@ (define virtual-height #f) (define virtual-width #f) + (define is-combo? (memq 'combo style)) + (define has-control-border? (and (not is-combo?) + (memq 'control-border style))) + (define-values (x-margin y-margin x-sb-margin y-sb-margin) (cond - [(memq 'control-border style) (values 3 3 3 3)] + [has-control-border? (values 3 3 3 3)] [(memq 'border style) (values 1 1 0 0)] [else (values 0 0 0 0)])) (define canvas-style style) (define/override (focus-is-on on?) - (when (memq 'control-border canvas-style) + (when has-control-border? (tellv cocoa setFocusState: #:type _BOOL on?) - (tellv cocoa setNeedsDisplay: #:type _BOOL #t))) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) + (super focus-is-on on?)) ;; Avoid multiple queued paints: (define paint-queued? #f) - ;; To handle paint requests that happen while on-paint - ;; is being called already: - (define now-drawing? #f) - (define refresh-after-drawing? #f) (define/public (queue-paint) ;; can be called from any thread, including the event-pump thread (unless paint-queued? (set! paint-queued? #t) - (queue-window-event this (lambda () - (set! paint-queued? #f) - (when (is-shown-to-root?) - (set! now-drawing? #t) - (fix-dc) - (on-paint) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh))))))) + (let ([req (request-flush-delay (get-cocoa-window))]) + (queue-window-event this (lambda () + (set! paint-queued? #f) + (when (is-shown-to-root?) + (send dc reset-backing-retained) ; start with a clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (queue-backing-flush) + (cancel-flush-delay req))))))) + + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0)) + (begin + (queue-paint) + #f))) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread + (queue-paint)) + + (define/public (queue-backing-flush) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) - (define is-combo? (memq 'combo style)) - (super-new [parent parent] [cocoa (as-objc-allocation (tell (tell (cond [is-combo? NSView] - [(memq 'control-border style) FocusView] + [has-control-border? FocusView] [(memq 'border style) (if (memq 'vscroll style) CornerlessFrameView FrameView)] @@ -249,34 +254,18 @@ (tellv content-cocoa setDelegate: content-cocoa) (install-control-font content-cocoa #f)) - (define dc (make-object dc% (make-graphics-context) 0 0 10 10 - (lambda () - (let ([w (box 0)] - [h (box 0)]) - (get-virtual-size w h) - (values (unbox w) (unbox h)))))) + (define dc (make-object dc% this)) + + (send dc start-backing-retained) (queue-paint) (define/public (get-dc) dc) - (define/public (fix-dc) + (define/public (fix-dc [refresh? #t]) (when (dc . is-a? . dc%) - (if (is-shown-to-before-root?) - (let ([p (tell #:type _NSPoint content-cocoa - convertPoint: #:type _NSPoint (make-NSPoint 0 0) - toView: #f)] - [xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (send dc reset-bounds - (+ (NSPoint-x p) (if is-combo? 2 0)) - (- (NSPoint-y p) (if is-combo? 22 0)) - (max 1 (- (unbox xb) (if is-combo? 22 0))) - (unbox yb) - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0))) - (send dc reset-bounds 0 0 0 0 0 0)))) + (send dc reset-backing-retained)) + (when refresh? (refresh))) (define/override (get-client-size xb yb) (super get-client-size xb yb) @@ -532,13 +521,9 @@ bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) - (if now-drawing? - (begin - (set! refresh-after-drawing? #t) - #f) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) - bg-col))) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col)) (define/public (reject-partial-update r) ;; Called in the event-pump thread. @@ -657,6 +642,14 @@ (define/public (set-resize-corner on?) (void)) + (define/public (get-backing-size xb yb) + (get-client-size xb yb) + (when is-combo? + (set-box! xb (- (unbox xb) 22)))) + + (define/public (is-flipped?) + (tell #:type _BOOL (get-cocoa-content) isFlipped)) + (define/public (get-virtual-size xb yb) (get-client-size xb yb) (when virtual-width (set-box! xb virtual-width)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index dd55ba0d..bfe3c8c9 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -1,16 +1,19 @@ #lang racket/base -(require ffi/unsafe/objc +(require racket/class ffi/unsafe - racket/class - "utils.rkt" - "types.rkt" + ffi/unsafe/objc racket/draw/cairo - racket/draw/dc racket/draw/local + "types.rkt" + "utils.rkt" + "window.rkt" + "../../lock.rkt" "../common/queue.rkt" - "../../syntax.rkt") + "../common/backing-dc.rkt") (provide dc% + do-backing-flush + _CGContextRef CGContextSetRGBFillColor CGContextFillRect @@ -19,79 +22,79 @@ CGContextAddLines) (define _CGContextRef (_cpointer 'CGContextRef)) +(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) -(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) +(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) -(define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) -(define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) - -(define dc-backend% - (class* default-dc-backend% (dc-backend<%>) - (init context dx dy width height -get-virtual-size) - (super-new) - - (inherit reset-cr set-auto-scroll) - - (define the-context context) ;; retain as long as we need `cg' - (define cg (tell #:type _CGContextRef context graphicsPort)) - - (define old-dx 0) - (define old-dy 0) - - (define/private (set-bounds dx dy width height) - (set! old-dx dx) - (set! old-dy (+ dy height)) - (CGContextTranslateCTM cg old-dx old-dy) - (CGContextScaleCTM cg 1 -1) - (let ([surface (cairo_quartz_surface_create_for_cg_context cg width height)]) - (set! cr (cairo_create surface)) - (cairo_surface_destroy surface)) - (set! clip-width width) - (set! clip-height height) - (reset-clip cr)) - - (define clip-width width) - (define clip-height height) - - (define/override (reset-clip cr) - (super reset-clip cr) - (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)]) - (cairo_get_matrix cr m) - (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0)) - (cairo_rectangle cr 0 0 clip-width clip-height) - (cairo_clip cr) - (cairo_set_matrix cr m))) - - (define cr #f) - (set-bounds dx dy width height) - - (define/public (reset-bounds dx dy width height auto-dx auto-dy) - (let ([old-cr cr]) - (when old-cr - (set! cr #f) - (cairo_destroy old-cr))) - (set-auto-scroll auto-dx auto-dy) - (CGContextScaleCTM cg 1 -1) - (CGContextTranslateCTM cg (- old-dx) (- old-dy)) - (set-bounds dx dy width height) - (reset-cr cr)) - - (define get-virtual-size -get-virtual-size) - (def/override (get-size) - (let-values ([(w h) (get-virtual-size)]) - (values (exact->inexact w) - (exact->inexact h)))) - - (define/override (get-cr) cr) - - (define/override (flush-cr) - (add-event-boundary-sometimes-callback! cg CGContextFlush)))) (define dc% - (dc-mixin dc-backend%)) + (class backing-dc% + (init [(cnvs canvas)]) + (define canvas cnvs) + (super-new) + + (define/override (get-backing-size xb yb) + (send canvas get-backing-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + (send canvas queue-backing-flush)) + + (define suspend-count 0) + (define req #f) + + (define/override (suspend-flush) + (as-entry + (lambda () + (when (zero? suspend-count) + (set! req (request-flush-delay (send canvas get-cocoa-window)))) + (set! suspend-count (add1 suspend-count)) + (super suspend-flush)))) + + (define/override (resume-flush) + (as-entry + (lambda () + (set! suspend-count (sub1 suspend-count)) + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f)) + (super resume-flush)))))) + +(define (do-backing-flush canvas dc ctx dx dy) + (tellv ctx saveGraphicsState) + (begin0 + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (unless (send canvas is-flipped?) + (CGContextTranslateCTM cg 0 (unbox h)) + (CGContextScaleCTM cg 1 -1)) + (CGContextTranslateCTM cg dx dy) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index c8b25782..660a13a0 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -55,12 +55,14 @@ (when wx (set! front wx) (send wx install-mb) + (send wx notify-responder #t) (queue-window-event wx (lambda () (send wx on-activate #t))))] [-a _void (windowDidResignMain: [_id notification]) (when wx (when (eq? front wx) (set! front #f)) (send empty-mb install) + (send wx notify-responder #f) (queue-window-event wx (lambda () (send wx on-activate #f))))]) @@ -150,6 +152,8 @@ (define/override (get-wx-window) this) (define/override (make-graphics-context) + (tell cocoa graphicsContext) + #; (as-objc-allocation (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) @@ -257,6 +261,28 @@ (define/override (is-view?) #f) + (define is-main? #f) + (define first-responder #f) + + (define/public (notify-responder on?) + (set! is-main? on?) + (when first-responder + (do-notify-responder first-responder on?))) + + (define/private (do-notify-responder wx on?) + (send wx focus-is-on on?) + (queue-window-event wx + (if on? + (lambda () (send wx on-set-focus)) + (lambda () (send wx on-kill-focus))))) + + (define/override (is-responder wx on?) + (if on? + (set! first-responder wx) + (set! first-responder #f)) + (when is-main? + (do-notify-responder wx on?))) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 57b8fc68..940acca5 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -206,8 +206,6 @@ (custodian-shutdown-all c))))))) (set! was-menu-bar #f))) -(define o (current-error-port)) - ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 0f99ecf7..0796b38c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -7,6 +7,7 @@ "const.rkt" "types.rkt" "keycode.rkt" + "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -15,9 +16,13 @@ (objc-unsafe!) (provide window% - queue-window-event + FocusResponder - KeyMouseResponder) + KeyMouseResponder + + queue-window-event + request-flush-delay + cancel-flush-delay) (define-local-member-name flip-client) @@ -30,16 +35,12 @@ [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) (begin - (send wx focus-is-on #t) - (queue-window-event wx (lambda () - (send wx on-set-focus))) + (send wx is-responder wx #t) #t))] [-a _BOOL (resignFirstResponder) (and (super-tell resignFirstResponder) (begin - (send wx focus-is-on #f) - (queue-window-event wx (lambda () - (send wx on-kill-focus))) + (send wx is-responder wx #f) #t))]) (define-objc-mixin (KeyMouseResponder Superclass) @@ -177,7 +178,11 @@ (unless no-show? (show #t)) - (define/public (focus-is-on on?) (void)) + (define/public (focus-is-on on?) + (void)) + + (define/public (is-responder wx on?) + (send parent is-responder wx on?)) (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) @@ -384,5 +389,37 @@ (def/public-unimplemented centre))) + +;; ---------------------------------------- + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) + +(define depth 0) + +(define (request-flush-delay cocoa-win) + (as-entry + (lambda () + (let ([req (box cocoa-win)]) + (set! depth (add1 depth)) + (tellv cocoa-win disableFlushWindow) + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (tellv cocoa-win flushWindow)))) + req)))) + +(define (cancel-flush-delay req) + (as-entry + (lambda () + (let ([cocoa-win (unbox req)]) + (when cocoa-win + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (remove-event-boundary-callback! req)))))) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index c8cef0ed..c3d3beea 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -3,21 +3,27 @@ racket/draw/dc racket/draw/bitmap-dc racket/draw/bitmap - racket/draw/local) + racket/draw/local + "../../lock.rkt" + "queue.rkt") (provide backing-dc% ;; scoped method names: get-backing-size - flush-backing - start-on-paint - end-on-paint) + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained) (define-local-member-name get-backing-size - flush-backing - start-on-paint - end-on-paint) + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained) (define backing-dc% (class (dc-mixin bitmap-dc-backend%) @@ -32,47 +38,83 @@ (set-box! xb 1) (set-box! yb 1)) - ;; override this method to push the bitmap to - ;; the device that it backs - (define/public (flush-backing bm) + ;; override this method to set up a callback to + ;; `on-backing-flush' when the backing store can be rendered + ;; to the screen + (define/public (queue-backing-flush) (void)) - (define on-paint-cr #f) + (define retained-cr #f) + (define retained-counter 0) + (define needs-flush? #f) - (define/public (start-on-paint) + ;; called with a procedure that is applied to a bitmap; + ;; returns #f if there's nothing to flush + (define/public (on-backing-flush proc) + (cond + [(not retained-cr) #f] + [(positive? retained-counter) + (proc (internal-get-bitmap)) + #t] + [else + (reset-backing-retained proc) + #t])) + + (define/public (reset-backing-retained [proc void]) + (let ([cr retained-cr]) + (when cr + (let ([bm (internal-get-bitmap)]) + (set! retained-cr #f) + (internal-set-bitmap #f #t) + (super release-cr retained-cr) + (proc bm) + (release-backing-bitmap bm))))) + + (define/public (start-backing-retained) (call-with-cr-lock (lambda () - (if on-paint-cr - (log-error "nested start-on-paint") - (set! on-paint-cr (get-cr)))))) + (set! retained-counter (add1 retained-counter))))) - (define/public (end-on-paint) + (define/public (end-backing-retained) (call-with-cr-lock (lambda () - (if (not on-paint-cr) + (if (zero? retained-counter) (log-error "unbalanced end-on-paint") - (let ([cr on-paint-cr]) - (set! on-paint-cr #f) - (release-cr cr)))))) + (set! retained-counter (sub1 retained-counter)))))) (define/override (get-cr) - (or on-paint-cr + (or retained-cr (let ([w (box 0)] [h (box 0)]) - (get-backing-size) + (get-backing-size w h) (let ([bm (get-backing-bitmap (unbox w) (unbox h))]) - (internal-set-bitmap bm)) - (super get-cr)))) + (internal-set-bitmap bm #t)) + (let ([cr (super get-cr)]) + (set! retained-cr cr) + cr)))) (define/override (release-cr cr) - (unless (eq? cr on-paint-cr) - (let ([bm (internal-get-bitmap)]) - (internal-set-bitmap #f) - (flush-backing bm) - (release-backing-bitmap bm)))))) + (when (zero? flush-suspends) + (queue-backing-flush))) + + (define flush-suspends 0) + + (define/override (suspend-flush) + (as-entry + (lambda () + ;; if not suspended currently, sleep to encourage any + ;; existing flush requests to complete + (when (zero? flush-suspends) (sleep)) + (set! flush-suspends (add1 flush-suspends))))) + (define/override (resume-flush) + (as-entry + (lambda () + (set! flush-suspends (sub1 flush-suspends)) + (when (zero? flush-suspends) + (queue-backing-flush))))))) (define (get-backing-bitmap w h) (make-object bitmap% w h #f #t)) (define (release-backing-bitmap bm) - (send bm release-bitma-storage)) + (send bm release-bitmap-storage)) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 0d9a76bf..e1a7d208 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -1340,18 +1340,25 @@ [bgmode (send dc get-text-mode)] [rgn (send dc get-clipping-region)]) + (send dc suspend-flush) + (send dc set-clipping-rect (- left x) (- top y) width height) - - (draw dc (- x) (- y) left top width height show-caret bg-color) - - (send dc set-clipping-region rgn) - - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode))))) + + (dynamic-wind + void + (lambda () + (draw dc (- x) (- y) left top width height show-caret bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) + + (send dc resume-flush))))))) (end-sequence-lock)))])) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 1d560f3f..e01fa2b4 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5042,16 +5042,23 @@ (send dc set-clipping-rect (- left x) (- top y) width height) - (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color) + (send dc suspend-flush) - (send dc set-clipping-region rgn) + (dynamic-wind + void + (lambda () + (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode)))))) + (send dc resume-flush)))))))) (end-sequence-lock)))])) From a13829397f6a3545baa466a9b052b56ab6dd2bb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 12:18:08 -0600 Subject: [PATCH 143/462] switch gtk to new canvas-refresh strategy original commit: 9f36c96960bd711c5dfee304963fc70ff25fb125 --- collects/mred/private/wx/common/queue.rkt | 2 + collects/mred/private/wx/gtk/canvas.rkt | 42 +++++---- collects/mred/private/wx/gtk/dc.rkt | 102 ++++++++++++---------- collects/mred/private/wxme/editor.rkt | 3 +- 4 files changed, 83 insertions(+), 66 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e05b2423..e7d5bd63 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -93,6 +93,8 @@ (define (add-event-boundary-callback! v proc) (hash-set! boundary-ht v proc)) (define (add-event-boundary-sometimes-callback! v proc) + (when (zero? (hash-count sometimes-boundary-ht)) + (set! last-time (current-inexact-milliseconds))) (hash-set! sometimes-boundary-ht v proc)) (define (remove-event-boundary-callback! v) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 36061022..ec3011a1 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -4,6 +4,8 @@ racket/draw ffi/unsafe/alloc racket/draw/color + racket/draw/local + "../common/backing-dc.rkt" "../../syntax.rkt" "../common/event.rkt" "utils.rkt" @@ -86,11 +88,11 @@ (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) - (when gc - (gdk_draw_rectangle (g_object_get_window gtk) gc #t - 0 0 32000 32000))) - (send wx queue-paint)) + (unless (send wx paint-or-queue-paint) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (g_object_get_window gtk) gc #t + 0 0 32000 32000))))) #t)) (define-signal-handler connect-expose-border "expose-event" @@ -220,18 +222,7 @@ (set-size x y w h) - (define dc (new dc% - [gtk client-gtk] - [get-client-size (lambda () - (let ([w (box 0)] - [h (box 0)]) - (get-virtual-size w h) - (values (unbox w) (unbox h))))] - [window-lock (send (get-top-win) get-dc-lock)] - [get-window (lambda (client-gtk) - (if is-combo? - (get-subwindow client-gtk) - (g_object_get_window client-gtk)))])) + (define dc (new dc% [canvas this])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) @@ -287,15 +278,27 @@ (queue-window-event this (lambda () (set! paint-queued? #f) (set! now-drawing? #t) + (send dc reset-backing-retained) ; clean slate (on-paint) (set! now-drawing? #f) (when refresh-after-drawing? (set! refresh-after-drawing? #f) (refresh)))))) + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (g_object_get_window client-gtk))) + (begin + (queue-paint) + #f))) + (define/public (on-paint) (void)) (define/override (refresh) + (queue-paint)) + + (define/public (queue-backing-flush) (gtk_widget_queue_draw client-gtk)) (define/public (reset-child-dcs) @@ -305,7 +308,10 @@ (register-as-child parent on?) (when on? (reset-child-dcs))) + (send dc start-backing-retained) + (define/private (reset-dc) + (send dc reset-backing-retained) (if auto-scroll? (send dc reset-dc (if virtual-width @@ -314,7 +320,7 @@ (if virtual-height (gtk_adjustment_get_value vscroll-adj) 0)) - (send dc reset-dc 0 0))) + (void))) (define/override (internal-on-client-size w h) (reset-dc)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 5beaf40d..2836b8f6 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -4,64 +4,72 @@ "utils.rkt" "types.rkt" "../../lock.rkt" + "../common/backing-dc.rkt" racket/draw/cairo racket/draw/dc racket/draw/local ffi/unsafe/alloc) -(provide dc% reset-dc) +(provide dc% + do-backing-flush) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) -(define-local-member-name - reset-dc) +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (define canvas cnvs) -(define dc-backend% - (class default-dc-backend% - (init-field gtk - get-client-size - window-lock - [get-window g_object_get_window]) - (inherit reset-cr set-auto-scroll) + (super-new) - (define c #f) - - (define/override (get-cr) - (or c - (let ([w (get-window gtk)]) - (and w - (begin - ;; Under Windows, creating a Cairo context within - ;; a frame inteferes with any other Cairo context - ;; within the same frame. So we use a lock to - ;; serialize drawing to different contexts. - (when window-lock (semaphore-wait window-lock)) - (set! c (gdk_cairo_create w)) - (reset-cr c) - c))))) - - (define/override (release-cr cr) - (when window-lock - (cairo_destroy c) - (set! c #f) - (semaphore-post window-lock))) - - (define/public (reset-dc scroll-dx scroll-dy) - ;; FIXME: ensure that the dc is not in use - (as-entry - (lambda () - (when c - (cairo_destroy c) - (set! c #f)) - (set-auto-scroll scroll-dx scroll-dy)))) + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) (define/override (get-size) - (let-values ([(w h) (get-client-size)]) - (values (exact->inexact w) - (exact->inexact h)))) - - (super-new))) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) -(define dc% - (dc-mixin dc-backend%)) + (define/override (queue-backing-flush) + (send canvas queue-backing-flush)) + + (define suspend-count 0) + (define req #f) + + (define/override (suspend-flush) + (as-entry + (lambda () + #; + (when (zero? suspend-count) + (set! req (request-flush-delay (send canvas get-cocoa-window)))) + (set! suspend-count (add1 suspend-count)) + (super suspend-flush)))) + + (define/override (resume-flush) + (as-entry + (lambda () + (set! suspend-count (sub1 suspend-count)) + #; + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f)) + (super resume-flush)))))) + +(define (do-backing-flush canvas dc win) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cr (gdk_cairo_create win)]) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index bf99cab2..4c88b64c 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -63,7 +63,8 @@ (define/public (set-last-used v) (set! last-used v)) (define/public (ready-offscreen width height) - (if (or (width . > . RIDICULOUS-SIZE) + (if (or #t ; disable on all platforms + (width . > . RIDICULOUS-SIZE) (height . > . RIDICULOUS-SIZE) (eq? (system-type) 'macosx)) #f From ad1eed5071fa53a06465a0270618a71f6e7397fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 13:18:23 -0600 Subject: [PATCH 144/462] restore auto-scroll canvases; fix text-rotation bug original commit: cc55bd7e93a521456d5b4cd17a061df4a447319d --- collects/mred/private/wx/cocoa/canvas.rkt | 5 +++- .../mred/private/wx/common/backing-dc.rkt | 4 +++- collects/mred/private/wx/gtk/canvas.rkt | 16 ++++++------- collects/mred/private/wx/gtk/dc.rkt | 24 +------------------ collects/tests/gracket/draw.rkt | 2 +- 5 files changed, 16 insertions(+), 35 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index b6bfe1ea..3ca578d1 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -264,7 +264,10 @@ (define/public (fix-dc [refresh? #t]) (when (dc . is-a? . dc%) - (send dc reset-backing-retained)) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0))) (when refresh? (refresh))) (define/override (get-client-size xb yb) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index c3d3beea..73fdfd5c 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -29,7 +29,8 @@ (class (dc-mixin bitmap-dc-backend%) (inherit call-with-cr-lock internal-get-bitmap - internal-set-bitmap) + internal-set-bitmap + reset-cr) (super-new) @@ -91,6 +92,7 @@ (internal-set-bitmap bm #t)) (let ([cr (super get-cr)]) (set! retained-cr cr) + (reset-cr cr) cr)))) (define/override (release-cr cr) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index ec3011a1..1991a0dd 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -312,15 +312,13 @@ (define/private (reset-dc) (send dc reset-backing-retained) - (if auto-scroll? - (send dc reset-dc - (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0) - (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0)) - (void))) + (send dc set-auto-scroll + (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0) + (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) (define/override (internal-on-client-size w h) (reset-dc)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 2836b8f6..3b9f69a2 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -33,29 +33,7 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - (send canvas queue-backing-flush)) - - (define suspend-count 0) - (define req #f) - - (define/override (suspend-flush) - (as-entry - (lambda () - #; - (when (zero? suspend-count) - (set! req (request-flush-delay (send canvas get-cocoa-window)))) - (set! suspend-count (add1 suspend-count)) - (super suspend-flush)))) - - (define/override (resume-flush) - (as-entry - (lambda () - (set! suspend-count (sub1 suspend-count)) - #; - (when (and (zero? suspend-count) req) - (cancel-flush-delay req) - (set! req #f)) - (super resume-flush)))))) + (send canvas queue-backing-flush)))) (define (do-backing-flush canvas dc win) (send dc on-backing-flush diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 8c738956..5bfdca03 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -967,7 +967,7 @@ (send dc clear) (send dc set-alpha current-alpha) - (send dc set-rotation current-rotation) + (send dc set-rotation (- current-rotation)) (send dc set-initial-matrix (if current-skew? (vector 1 0 0.2 1 3 0) (vector 1 0 0 1 0 0))) From 6737bc0e58d24be14eeb349ed14ec6f4622da882 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 18:20:52 -0600 Subject: [PATCH 145/462] fix gtk widget size info for sizing and positioning original commit: b020c2f858caf30364e633dc19894cae3d21e47e --- collects/mred/private/wx/gtk/canvas.rkt | 6 ++- .../mred/private/wx/gtk/client-window.rkt | 1 + collects/mred/private/wx/gtk/frame.rkt | 12 +++-- collects/mred/private/wx/gtk/group-panel.rkt | 14 ++---- collects/mred/private/wx/gtk/menu-bar.rkt | 18 ++++++- collects/mred/private/wx/gtk/tab-panel.rkt | 22 +++++---- collects/mred/private/wx/gtk/window.rkt | 48 +++++++++++++++++-- collects/tests/gracket/draw.rkt | 2 +- 8 files changed, 96 insertions(+), 27 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 1991a0dd..5609d9d3 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -137,7 +137,8 @@ [gl-config #f]) (inherit get-gtk set-size get-size get-client-size - on-size register-as-child get-top-win) + on-size register-as-child get-top-win + set-auto-size adjust-client-delta) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -252,6 +253,9 @@ (when hscroll-adj (connect-value-changed-h hscroll-adj)) (when vscroll-adj (connect-value-changed-v vscroll-adj)) + (set-auto-size) + (adjust-client-delta margin margin) + (define/override (direct-update?) #f) (define/public (get-dc) dc) diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 9fbfe586..79b562a3 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -57,6 +57,7 @@ (set! client-w w) (set! client-h h)) + #; (define/override (get-client-size xb yb) (set-box! xb client-w) (set-box! yb client-h)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8e67ae9a..045ae06a 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -97,7 +97,8 @@ (inherit get-gtk set-size on-size pre-on-char pre-on-event get-client-delta get-size - get-parent get-eventspace) + get-parent get-eventspace + adjust-client-delta) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) (when (memq 'no-caption style) @@ -133,10 +134,15 @@ (define/public (on-close) (void)) (define/public (set-menu-bar mb) - (send mb set-top-window this) (let ([mb-gtk (send mb get-gtk)]) (gtk_box_pack_start vbox-gtk mb-gtk #t #t 0) - (gtk_widget_show mb-gtk))) + (gtk_widget_show mb-gtk)) + (let ([h (send mb set-top-window this)]) + ;; adjust client delta right away, so that we make + ;; better assumptions about the client size and more + ;; quickly converge to the right size of the frame + ;; based on its content + (adjust-client-delta 0 h))) (define saved-enforcements (vector 0 0 -1 -1)) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index 2550a2c0..a147a034 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -17,6 +17,7 @@ (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) (define-gtk gtk_frame_set_label (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_frame_get_label_widget (_fun _GtkWidget -> _GtkWidget)) (define group-panel% (class (client-size-mixin (panel-mixin window%)) @@ -25,7 +26,8 @@ style label) - (inherit set-size set-auto-size get-gtk get-height) + (inherit set-size set-auto-size infer-client-delta + get-gtk get-height) (define gtk (gtk_frame_new label)) (define client-gtk (gtk_fixed_new)) @@ -38,17 +40,9 @@ [extra-gtks (list client-gtk)] [no-show? (memq 'deleted style)]) + (infer-client-delta #t #t (gtk_frame_get_label_widget gtk)) (set-auto-size) - ;; The delta between the group box height and its - ;; client height can go bad if the label is set. - ;; Avoid the problem by effectively using the - ;; original delta. - (define orig-h (get-height)) - (define/override (get-client-size xb yb) - (super get-client-size xb yb) - (set-box! yb (- (get-height) orig-h))) - (define/public (set-label s) (gtk_frame_set_label gtk s)) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 20d225e5..b1afb74a 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -5,6 +5,7 @@ "../common/freeze.rkt" "../common/queue.rkt" "widget.rkt" + "window.rkt" "utils.rkt" "types.rkt") (unsafe!) @@ -22,6 +23,8 @@ (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_widget_set_usize (_fun _GtkWidget _int _int -> _void)) + (define (fixup-mneumonic title) (regexp-replace* "&&" @@ -76,9 +79,22 @@ (connect-menu-button-press gtk) (define top-wx #f) + (define/public (set-top-window top) (set! top-wx top) - (install-widget-parent top)) + (install-widget-parent top) + ;; return initial size; also, add a menu to make sure there is one, + ;; and force the menu bar to be at least that tall always + (let ([item (gtk_menu_item_new_with_mnemonic "Xyz")]) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item) + (begin0 + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (gtk_widget_set_usize gtk -1 (GtkRequisition-height req)) + (GtkRequisition-height req)) + (gtk_container_remove gtk item)))) + (define/public (get-top-window) top-wx) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index ab06e85d..8e1bc1b6 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -44,13 +44,22 @@ style labels) - (inherit set-size set-auto-size get-gtk - reset-child-dcs) + (inherit set-size set-auto-size infer-client-delta get-gtk + reset-child-dcs get-height) (define gtk (gtk_notebook_new)) ;; Reparented so that it's always in the current page's bin: (define client-gtk (gtk_fixed_new)) + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + ; Once without tabs to set client-width delta: + (infer-client-delta #t #f) + (define empty-bin-gtk (gtk_hbox_new #f 0)) (define current-bin-gtk #f) @@ -80,14 +89,11 @@ (select-bin (page-bin-gtk (car pages))))) (gtk_widget_show client-gtk) - (super-new [parent parent] - [gtk gtk] - [client-gtk client-gtk] - [extra-gtks (list client-gtk)] - [no-show? (memq 'deleted style)]) - (connect-key-and-mouse gtk) + ; With tabs to set client-width delta: + (infer-client-delta #f #t) + (set-auto-size) (define callback void) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index c0f652d8..c3b726d6 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -76,6 +76,16 @@ (connect-focus-in gtk) (connect-focus-out gtk)) +(define-signal-handler connect-size-allocate "size-allocate" + (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (send wx save-size + (GtkAllocation-x a) + (GtkAllocation-y a) + (GtkAllocation-width a) + (GtkAllocation-height a))) + #t)) ;; ---------------------------------------- (define-signal-handler connect-key-press "key-press-event" @@ -256,6 +266,8 @@ (define save-w 0) (define save-h 0) + (connect-size-allocate gtk) + (when add-to-parent? (gtk_container_add (send parent get-client-gtk) gtk)) @@ -275,10 +287,16 @@ (unless (= y -11111) (set! save-y y)) (unless (= w -1) (set! save-w w)) (unless (= h -1) (set! save-h h)) + (set! save-w (max save-w client-delta-w)) + (set! save-h (max save-h client-delta-h)) (tentative-client-size (+ save-w client-delta-w) (+ save-h client-delta-h)) (really-set-size gtk save-x save-y save-w save-h))) + (define/public (save-size x y w h) + (set! save-w w) + (set! save-h h)) + (define/public (really-set-size gtk x y w h) (send parent set-child-size gtk x y w h)) @@ -296,14 +314,36 @@ (define client-delta-w 0) (define client-delta-h 0) + (define min-client-delta-w 0) + (define min-client-delta-h 0) (define/public (remember-client-size w h) ;; Called in the Gtk event-loop thread - (set! client-delta-w (max 0 (- save-w w))) - (set! client-delta-h (max 0 (- save-h h))) + ;(set! client-delta-w (max min-client-delta-w (- save-w w))) + ;(set! client-delta-h (max min-client-delta-h (- save-h h))) (queue-window-event this (lambda () (on-size 0 0)))) (define/public (tentative-client-size w h) (void)) + (define/public (adjust-client-delta dw dh) + (set! client-delta-w dw) + (set! client-delta-h dh)) + + (define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f]) + (let ([req (make-GtkRequisition 0 0)] + [creq (make-GtkRequisition 0 0)] + [hreq (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (gtk_widget_size_request (get-client-gtk) creq) + (when sub-h-gtk + (gtk_widget_size_request sub-h-gtk hreq)) + (when w? + (set! client-delta-w (- (GtkRequisition-width req) + (max (GtkRequisition-width creq) + (GtkRequisition-width hreq))))) + (when h? + (set! client-delta-h (- (GtkRequisition-height req) + (GtkRequisition-height creq)))))) + (define/public (set-auto-size) (let ([req (make-GtkRequisition 0 0)]) (gtk_widget_size_request gtk req) @@ -345,7 +385,9 @@ (set-box! xb save-w) (set-box! yb save-h)) (define/public (get-client-size xb yb) - (get-size xb yb)) + (get-size xb yb) + (set-box! xb (max 0 (- (unbox xb) client-delta-w))) + (set-box! yb (max 0 (- (unbox yb) client-delta-h)))) (define enabled? #t) (define/pubment (is-enabled-to-root?) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 5bfdca03..066da70e 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -262,7 +262,7 @@ (override* [on-paint (case-lambda - [() (on-paint #f)] + [() (time (on-paint #f))] [(ps?) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] From f576357124bd08be0dbd4e9ffb9e3433efa8e48f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 19:42:09 -0600 Subject: [PATCH 146/462] fix problem with size initialization of a frame with a menu bar original commit: e433a8a2e6be414f16b5fbc1d58b321dc20fd7fe --- collects/mred/private/wx/gtk/frame.rkt | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 045ae06a..36d2a531 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -22,7 +22,7 @@ (define-gtk gtk_window_new (_fun _int -> _GtkWidget)) (define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) -(define-gtk gtk_fixed_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) (define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int)) -> _void @@ -93,7 +93,7 @@ x y w h style) (init [is-dialog? #f]) - + (inherit get-gtk set-size on-size pre-on-char pre-on-event get-client-delta get-size @@ -104,7 +104,7 @@ (when (memq 'no-caption style) (gtk_window_set_decorated gtk #f)) (define vbox-gtk (gtk_vbox_new #f 0)) - (define panel-gtk (gtk_fixed_new #f 10)) + (define panel-gtk (gtk_fixed_new)) (gtk_container_add gtk vbox-gtk) (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0) (gtk_widget_show vbox-gtk) @@ -142,7 +142,11 @@ ;; better assumptions about the client size and more ;; quickly converge to the right size of the frame ;; based on its content - (adjust-client-delta 0 h))) + (adjust-client-delta 0 h)) + ;; Hack: calls back into the mred layer to re-compute + ;; sizes. By calling this early enough, the frame won't + ;; grow if it doesn't have to grow to accomodate the menu bar. + (send this resized)) (define saved-enforcements (vector 0 0 -1 -1)) From eff0fc727b67cbb712771300f748d18bfec274eb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 5 Aug 2010 14:39:12 -0400 Subject: [PATCH 147/462] Implement GTK-native file selector original commit: 15880ea8e5d76fdebf6386d0d654b45bad5e1334 --- collects/mred/private/filedialog.rkt | 8 +- collects/mred/private/wx/gtk/procs.rkt | 97 ++++++++++++++++++++++++- collects/mred/private/wx/gtk/types.rkt | 2 +- collects/mred/private/wx/gtk/utils.rkt | 41 +++++++++++ collects/mred/private/wx/gtk/widget.rkt | 4 + 5 files changed, 147 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 9babd087..5fbe6e37 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -50,11 +50,13 @@ (string? (cadr p)))) filters)) (raise-type-error who "list of 2-string lists" filters)) + (printf "parent window: ~a ~a\n" parent (and parent (mred->wx parent))) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) (if (or std? - #t ; for now, always use the manually constructed dialog - (eq? (system-type) 'unix)) + ;#t ; for now, always use the manually constructed dialog + ;; the platform dialog is only available for Gtk + (not (eq? (system-type) 'unix))) (send (new path-dialog% [put? put?] [dir? dir?] @@ -71,6 +73,8 @@ (let ([s (wx:file-selector message directory filename extension ;; file types: + filters + #; (apply string-append (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) filters)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 0c37c0c2..2245c401 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -4,8 +4,10 @@ "../../lock.rkt" racket/class racket/draw + racket/match "types.rkt" "utils.rkt" + "widget.rkt" "../common/handlers.rkt") (provide @@ -61,7 +63,6 @@ show-print-setup can-show-print-setup?) - (define-unimplemented special-control-key) (define-unimplemented special-option-key) (define-unimplemented get-color-from-user) @@ -121,7 +122,99 @@ (define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) (define-unimplemented is-color-display?) -(define-unimplemented file-selector) + +(define _GtkFileChooserDialog (_cpointer 'GtkFileChooserDialog)) +(define _GtkFileChooser (_cpointer 'GtkFileChooser)) +(define _GtkFileChooserAction + (_enum (list 'open 'save 'select-folder 'create-folder))) + +(define _GtkResponse + (_enum + '(none = -1 + reject = -2 + accept = -3 + delete-event = -4 + ok = -5 + cancel = -6 + close = -7 + yes = -8 + no = -9 + apply = -10 + help = -11) + _fixint)) +(define _GtkDialog (_cpointer 'GtkDialog)) +;; FIXME: really there are varargs here, but we don't need them for +;; our purposes +(define-gtk gtk_file_chooser_dialog_new + (_fun _string (_or-null _GtkWindow) + _GtkFileChooserAction + _string _GtkResponse + _string _GtkResponse + (_or-null _pointer) + -> _GtkFileChooserDialog)) +;; FIXME - should really be _GtkDialog but no subtyping +(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int)) +;; FIXME ;; these should really be _GtkFileChooser but no subtyping +(define-gtk gtk_file_chooser_get_filename + (_fun _GtkFileChooserDialog -> _gpath/free)) +(define-gtk gtk_file_chooser_get_filenames + (_fun _GtkFileChooserDialog -> (_GSList _gpath/free))) +(define-gtk gtk_file_chooser_set_current_name + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_current_folder + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_select_multiple + (_fun _GtkFileChooserDialog _gboolean -> _void)) + +(define _GtkFileFilter (_cpointer 'GtkFileFilter)) +(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter)) +(define-gtk gtk_file_filter_set_name + (_fun _GtkFileFilter _string -> _void)) +(define-gtk gtk_file_filter_add_pattern + (_fun _GtkFileFilter _string -> _void)) + +(define-gtk gtk_file_chooser_add_filter + (_fun _GtkFileChooserDialog _GtkFileFilter -> _void)) + +(define (file-selector message directory filename + extension ;; always ignored + filters style parent) + (define type (car style)) ;; the rest of `style' is irrelevant on Gtk + (define dlg (gtk_file_chooser_dialog_new + message (and parent (send parent get-gtk)) + (case type + [(dir) 'select-directory] + [(put) 'save] + [else 'open]) + "gtk-cancel" 'cancel + ;; no stock names for "Select" + (case type + [(dir) "Choose"] + [(put) "gtk-save"] + [(get) "gtk-open"] + [(multi) "Choose"]) + 'accept + #f)) + (when (eq? 'multi type) + (gtk_file_chooser_set_select_multiple dlg #t)) + (when filename + (gtk_file_chooser_set_current_name dlg filename)) + (when directory + (gtk_file_chooser_set_current_folder dlg directory)) + (for ([f (in-list filters)]) + (match f + [(list name glob) + (let ([ff (gtk_file_filter_new)]) + (gtk_file_filter_set_name ff name) + (gtk_file_filter_add_pattern ff glob) + (gtk_file_chooser_add_filter dlg ff))])) + (define ans (and (= -3 (gtk_dialog_run dlg)) + (if (eq? type 'multi) + (gtk_file_chooser_get_filenames dlg) + (gtk_file_chooser_get_filename dlg)))) + (gtk_widget_destroy dlg) + ans) + (define (id-to-menu-item i) i) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 6d2aa48c..95103c5b 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -111,4 +111,4 @@ [send_event _byte] [area _GdkRectangle] [region _pointer] - [count _int])) \ No newline at end of file + [count _int])) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 5524e577..4efd0433 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/unsafe ffi/unsafe/define + (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") @@ -15,6 +16,10 @@ g_object_ref g_object_unref + g_free + _gpath/free + _GSList + g_object_set_data g_object_get_data @@ -77,6 +82,8 @@ (define-gobj g_object_ref (_fun _pointer -> _void)) (define-gobj g_object_unref (_fun _pointer -> _void)) +(define-gobj g_free (_fun _pointer -> _void)) + (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) @@ -115,3 +122,37 @@ (function-ptr handler-proc (_fun #:atomic? #t . args))) (define (connect-name gtk [user-data #f]) (g_signal_connect gtk signal-name handler_function user-data)))) + + +(define _gpath/free + (make-ctype _pointer + path->bytes ; a Racket bytes can be used as a pointer + (lambda (x) + (let ([b (bytes->path (make-byte-string x))]) + (g_free x) + b)))) + +(define-cstruct _g-slist + ([data _pointer] + [next (_or-null _g-slist-pointer)])) + +(define-gobj g_slist_free (_fun _g-slist-pointer -> _void)) +;; This should probably be provided by Racket +(define make-byte-string + (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket))) + +(define (_GSList elem) + (make-ctype (_or-null _g-slist-pointer) + (lambda (l) + (let L ([l l]) + (if (null? l) + #f + (make-g-slist (car l) (L (cdr l)))))) + (lambda (gl) + (begin0 + (let L ([gl gl]) + (if (not gl) + null + (cons ((ctype-c->scheme elem) (g-slist-data gl)) + (L (g-slist-next gl))))) + (g_slist_free gl))))) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index c8e8ea54..a836f516 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -13,6 +13,7 @@ gtk_widget_show gtk_widget_hide + gtk_widget_destroy gtk_vbox_new gtk_hbox_new @@ -22,6 +23,9 @@ (define-gtk gtk_widget_show (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_destroy (_fun _pointer -> _void)) + + (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) From 3737a9679154365b3cde451927579043229325ab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 20:17:03 -0600 Subject: [PATCH 148/462] patches to make file dialog work original commit: 1b641c360733af1205969beeb189ca8013988312 --- collects/mred/private/filedialog.rkt | 1 - collects/mred/private/wx/gtk/procs.rkt | 24 ++++++++++++++++++---- collects/mred/private/wx/gtk/radio-box.rkt | 2 +- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 5fbe6e37..0980dc4a 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -50,7 +50,6 @@ (string? (cadr p)))) filters)) (raise-type-error who "list of 2-string lists" filters)) - (printf "parent window: ~a ~a\n" parent (and parent (mred->wx parent))) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) (if (or std? diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 2245c401..f64b02df 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -8,7 +8,8 @@ "types.rkt" "utils.rkt" "widget.rkt" - "../common/handlers.rkt") + "../common/handlers.rkt" + "../common/queue.rkt") (provide special-control-key @@ -123,7 +124,7 @@ (define-unimplemented is-color-display?) -(define _GtkFileChooserDialog (_cpointer 'GtkFileChooserDialog)) +(define _GtkFileChooserDialog _GtkWidget) (define _GtkFileChooser (_cpointer 'GtkFileChooser)) (define _GtkFileChooserAction (_enum (list 'open 'save 'select-folder 'create-folder))) @@ -142,7 +143,6 @@ apply = -10 help = -11) _fixint)) -(define _GtkDialog (_cpointer 'GtkDialog)) ;; FIXME: really there are varargs here, but we don't need them for ;; our purposes (define-gtk gtk_file_chooser_dialog_new @@ -208,13 +208,29 @@ (gtk_file_filter_set_name ff name) (gtk_file_filter_add_pattern ff glob) (gtk_file_chooser_add_filter dlg ff))])) - (define ans (and (= -3 (gtk_dialog_run dlg)) + (define ans (and (= -3 (show-dialog dlg)) (if (eq? type 'multi) (gtk_file_chooser_get_filenames dlg) (gtk_file_chooser_get_filename dlg)))) (gtk_widget_destroy dlg) ans) +(define response-sema (make-semaphore)) +(define response-val #f) + +(define-signal-handler connect-response "response" + (_fun _GtkWidget _int -> _void) + (lambda (gtk id) + (set! response-val id) + (semaphore-post response-sema))) + +(define (show-dialog dlg-gtk) + (connect-response dlg-gtk) + (gtk_widget_show dlg-gtk) + (yield response-sema) + (gtk_widget_hide dlg-gtk) + response-val) + (define (id-to-menu-item i) i) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 4a1466a2..68285a9d 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -3,7 +3,7 @@ scheme/foreign "../../syntax.rkt" "item.rkt" - "utils.rkt" + (except-in "utils.rkt" _GSList) "types.rkt" "widget.rkt" "window.rkt" From d4de5ceb8e18e4393669c998361ce1c71203ddaf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Aug 2010 21:19:56 -0600 Subject: [PATCH 149/462] make gtk file dialog place nicely original commit: d34d3969d90e2ed1ab57e13b98ec7819beb32850 --- collects/mred/private/filedialog.rkt | 5 +- collects/mred/private/wx/gtk/filedialog.rkt | 146 ++++++++++++++++++++ collects/mred/private/wx/gtk/procs.rkt | 117 +--------------- collects/mred/private/wx/gtk/queue.rkt | 5 +- 4 files changed, 158 insertions(+), 115 deletions(-) create mode 100644 collects/mred/private/wx/gtk/filedialog.rkt diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 0980dc4a..026dfe65 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -53,9 +53,8 @@ (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) (if (or std? - ;#t ; for now, always use the manually constructed dialog - ;; the platform dialog is only available for Gtk - (not (eq? (system-type) 'unix))) + ;; no Cocoa dialog, yet: + (eq? (system-type) 'macosx)) (send (new path-dialog% [put? put?] [dir? dir?] diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt new file mode 100644 index 00000000..c26bd77b --- /dev/null +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -0,0 +1,146 @@ +#lang racket/base +(require ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + racket/class + racket/match + "types.rkt" + "utils.rkt" + "widget.rkt" + "queue.rkt" + "../common/handlers.rkt" + "../common/queue.rkt") + +(provide file-selector) + +(define _GtkFileChooserDialog _GtkWidget) +(define _GtkFileChooser (_cpointer 'GtkFileChooser)) +(define _GtkFileChooserAction + (_enum (list 'open 'save 'select-folder 'create-folder))) + +(define _GtkResponse + (_enum + '(none = -1 + reject = -2 + accept = -3 + delete-event = -4 + ok = -5 + cancel = -6 + close = -7 + yes = -8 + no = -9 + apply = -10 + help = -11) + _fixint)) +;; FIXME: really there are varargs here, but we don't need them for +;; our purposes +(define-gtk gtk_file_chooser_dialog_new + (_fun _string (_or-null _GtkWindow) + _GtkFileChooserAction + _string _GtkResponse + _string _GtkResponse + (_or-null _pointer) + -> _GtkFileChooserDialog)) +;; FIXME - should really be _GtkDialog but no subtyping +(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int)) +;; FIXME ;; these should really be _GtkFileChooser but no subtyping +(define-gtk gtk_file_chooser_get_filename + (_fun _GtkFileChooserDialog -> _gpath/free)) +(define-gtk gtk_file_chooser_get_filenames + (_fun _GtkFileChooserDialog -> (_GSList _gpath/free))) +(define-gtk gtk_file_chooser_set_current_name + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_current_folder + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_select_multiple + (_fun _GtkFileChooserDialog _gboolean -> _void)) + +(define _GtkFileFilter (_cpointer 'GtkFileFilter)) +(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter)) +(define-gtk gtk_file_filter_set_name + (_fun _GtkFileFilter _string -> _void)) +(define-gtk gtk_file_filter_add_pattern + (_fun _GtkFileFilter _string -> _void)) + +(define-gtk gtk_file_chooser_add_filter + (_fun _GtkFileChooserDialog _GtkFileFilter -> _void)) + +(define (file-selector message directory filename + extension ;; always ignored + filters style parent) + (define type (car style)) ;; the rest of `style' is irrelevant on Gtk + (define dlg (gtk_file_chooser_dialog_new + message (and parent (send parent get-gtk)) + (case type + [(dir) 'select-directory] + [(put) 'save] + [else 'open]) + "gtk-cancel" 'cancel + ;; no stock names for "Select" + (case type + [(dir) "Choose"] + [(put) "gtk-save"] + [(get) "gtk-open"] + [(multi) "Choose"]) + 'accept + #f)) + (when (eq? 'multi type) + (gtk_file_chooser_set_select_multiple dlg #t)) + (when filename + (gtk_file_chooser_set_current_name dlg filename)) + (when directory + (gtk_file_chooser_set_current_folder dlg directory)) + (for ([f (in-list filters)]) + (match f + [(list name glob) + (let ([ff (gtk_file_filter_new)]) + (gtk_file_filter_set_name ff name) + (gtk_file_filter_add_pattern ff glob) + (gtk_file_chooser_add_filter dlg ff))])) + (define ans (and (= -3 (show-dialog dlg + (lambda (v) + (or (not (= v -3)) + ;; FIXME: for get mode, probably should check file vs. + ;; directory name + (not (eq? type 'put)) + (not (file-exists? (gtk_file_chooser_get_filename dlg))) + ;; FIXME: need to ask "replace the file? here + #t)))) + (if (eq? type 'multi) + (gtk_file_chooser_get_filenames dlg) + (gtk_file_chooser_get_filename dlg)))) + (gtk_widget_destroy dlg) + ans) + +(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) + +(define-signal-handler connect-response "response" + (_fun _GtkWidget _int _pointer -> _void) + (lambda (gtk id data) + (let* ([p (ptr-ref data _racket)] + [response-sema (car p)] + [response-box (cdr p)]) + (set-box! response-box id) + (semaphore-post response-sema)))) + +(define (show-dialog dlg-gtk + [validate? (lambda (val) #t)]) + (let* ([response-sema (make-semaphore)] + [response-box (box #f)] + [cell (malloc-immobile-cell (cons response-sema + response-box))]) + (connect-response dlg-gtk cell) + (gtk_widget_show dlg-gtk) + (let loop () + (yield response-sema) + (unless (validate? (unbox response-box)) + (loop))) + (free-immobile-cell cell) ;; FIXME : don't leak + (gtk_widget_hide dlg-gtk) + (unbox response-box))) + +(define (id-to-menu-item i) i) +(define-unimplemented get-the-x-selection) +(define-unimplemented get-the-clipboard) +(define-unimplemented show-print-setup) +(define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index f64b02df..8753291b 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -4,12 +4,11 @@ "../../lock.rkt" racket/class racket/draw - racket/match + "filedialog.rkt" "types.rkt" "utils.rkt" "widget.rkt" - "../common/handlers.rkt" - "../common/queue.rkt") + "../common/handlers.rkt") (provide special-control-key @@ -81,7 +80,10 @@ (define (set-dialogs . args) (void)) (define (set-executer e) (void)) (define-unimplemented send-event) -(define-unimplemented file-creator-and-type) +(define file-creator-and-type + (case-lambda + [(path cr ty) (void)] + [(path) (values #"????" #"????")])) (define (begin-refresh-sequence) (void)) (define (end-refresh-sequence) (void)) (define-unimplemented run-printout) @@ -124,113 +126,6 @@ (define-unimplemented is-color-display?) -(define _GtkFileChooserDialog _GtkWidget) -(define _GtkFileChooser (_cpointer 'GtkFileChooser)) -(define _GtkFileChooserAction - (_enum (list 'open 'save 'select-folder 'create-folder))) - -(define _GtkResponse - (_enum - '(none = -1 - reject = -2 - accept = -3 - delete-event = -4 - ok = -5 - cancel = -6 - close = -7 - yes = -8 - no = -9 - apply = -10 - help = -11) - _fixint)) -;; FIXME: really there are varargs here, but we don't need them for -;; our purposes -(define-gtk gtk_file_chooser_dialog_new - (_fun _string (_or-null _GtkWindow) - _GtkFileChooserAction - _string _GtkResponse - _string _GtkResponse - (_or-null _pointer) - -> _GtkFileChooserDialog)) -;; FIXME - should really be _GtkDialog but no subtyping -(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int)) -;; FIXME ;; these should really be _GtkFileChooser but no subtyping -(define-gtk gtk_file_chooser_get_filename - (_fun _GtkFileChooserDialog -> _gpath/free)) -(define-gtk gtk_file_chooser_get_filenames - (_fun _GtkFileChooserDialog -> (_GSList _gpath/free))) -(define-gtk gtk_file_chooser_set_current_name - (_fun _GtkFileChooserDialog _path -> _void)) -(define-gtk gtk_file_chooser_set_current_folder - (_fun _GtkFileChooserDialog _path -> _void)) -(define-gtk gtk_file_chooser_set_select_multiple - (_fun _GtkFileChooserDialog _gboolean -> _void)) - -(define _GtkFileFilter (_cpointer 'GtkFileFilter)) -(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter)) -(define-gtk gtk_file_filter_set_name - (_fun _GtkFileFilter _string -> _void)) -(define-gtk gtk_file_filter_add_pattern - (_fun _GtkFileFilter _string -> _void)) - -(define-gtk gtk_file_chooser_add_filter - (_fun _GtkFileChooserDialog _GtkFileFilter -> _void)) - -(define (file-selector message directory filename - extension ;; always ignored - filters style parent) - (define type (car style)) ;; the rest of `style' is irrelevant on Gtk - (define dlg (gtk_file_chooser_dialog_new - message (and parent (send parent get-gtk)) - (case type - [(dir) 'select-directory] - [(put) 'save] - [else 'open]) - "gtk-cancel" 'cancel - ;; no stock names for "Select" - (case type - [(dir) "Choose"] - [(put) "gtk-save"] - [(get) "gtk-open"] - [(multi) "Choose"]) - 'accept - #f)) - (when (eq? 'multi type) - (gtk_file_chooser_set_select_multiple dlg #t)) - (when filename - (gtk_file_chooser_set_current_name dlg filename)) - (when directory - (gtk_file_chooser_set_current_folder dlg directory)) - (for ([f (in-list filters)]) - (match f - [(list name glob) - (let ([ff (gtk_file_filter_new)]) - (gtk_file_filter_set_name ff name) - (gtk_file_filter_add_pattern ff glob) - (gtk_file_chooser_add_filter dlg ff))])) - (define ans (and (= -3 (show-dialog dlg)) - (if (eq? type 'multi) - (gtk_file_chooser_get_filenames dlg) - (gtk_file_chooser_get_filename dlg)))) - (gtk_widget_destroy dlg) - ans) - -(define response-sema (make-semaphore)) -(define response-val #f) - -(define-signal-handler connect-response "response" - (_fun _GtkWidget _int -> _void) - (lambda (gtk id) - (set! response-val id) - (semaphore-post response-sema))) - -(define (show-dialog dlg-gtk) - (connect-response dlg-gtk) - (gtk_widget_show dlg-gtk) - (yield response-sema) - (gtk_widget_hide dlg-gtk) - response-val) - (define (id-to-menu-item i) i) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index e5cd5cf2..ef552b4c 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -62,6 +62,7 @@ (define-mz scheme_get_fdset (_fun _pointer _int -> _pointer)) (define-mz scheme_fdset (_fun _pointer _int -> _void)) +(define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void)) (define (install-wakeup fds) (pre-event-sync #t) @@ -70,7 +71,9 @@ timeout poll-fds poll-fd-count)]) - ;; FIXME: use the `timeout' result + (let ([to (ptr-ref timeout _int)]) + (when (to . >= . 0) + (scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to)))) (if (n . > . poll-fd-count) (begin (set! poll-fds (malloc _GPollFD n)) From ae649f506b811319f656274906a21b70e037597f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 7 Aug 2010 12:43:19 -0600 Subject: [PATCH 150/462] consolidate lock implementation and fix custodian problem original commit: 8ad33f15ab876d83bdc2e38041870f5e29317266 --- collects/mred/private/wx/cocoa/queue.rkt | 2 +- collects/mred/private/wx/common/freeze.rkt | 103 ++++----------------- collects/mred/private/wx/common/queue.rkt | 22 +++-- collects/mred/private/wx/gtk/queue.rkt | 2 +- 4 files changed, 32 insertions(+), 97 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 940acca5..d22745d9 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -228,7 +228,7 @@ (begin (retain evt) (queue-event e (lambda () - (call-as-unfreeze-point + (call-as-nonatomic-retry-point (lambda () (tellv app sendEvent: evt) (release evt)))))) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index d84cd487..28b3fecc 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -1,41 +1,10 @@ #lang scheme/base -(require scheme/foreign - racket/draw/hold - "utils.rkt" - "queue.rkt" - ffi/unsafe/atomic) -(unsafe!) +(require ffi/unsafe/try-atomic + "queue.rkt") -(provide call-as-unfreeze-point +(provide call-as-nonatomic-retry-point constrained-reply) -(define-mz scheme_abort_continuation_no_dws (_fun _scheme _scheme -> _scheme)) -(define-mz scheme_call_with_composable_no_dws (_fun _scheme _scheme -> _scheme)) -(define-mz scheme_set_on_atomic_timeout (_fun (_fun -> _void) -> _pointer)) -(define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer) - #:c-id scheme_set_on_atomic_timeout) - -(define freezer-box (make-parameter #f)) -(define freeze-tag (make-continuation-prompt-tag)) - -;; Runs `thunk' atomically, but cooperates with -;; `constrained-reply' to continue a frozen -;; computation in non-atomic mode. -(define (call-as-unfreeze-point thunk) - (let ([b (box null)]) - (parameterize ([freezer-box b]) - ;; In atomic mode: - (call-as-atomic (lambda () (thunk))) - ;; Out of atomic mode: - (let ([l (unbox b)]) - (for ([k (in-list (reverse l))]) - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt - k - freeze-tag))))) - (void)))) - (define (internal-error str) (log-error (apply string-append @@ -64,56 +33,18 @@ ;; FIXME: waiting 200msec is not a good enough rule. (define (constrained-reply es thunk default - [should-give-up? - (let ([now (current-inexact-milliseconds)]) - (lambda () - ((current-inexact-milliseconds) . > . (+ now 200))))] #:fail-result [fail-result default]) - (let ([b (freezer-box)]) - (cond - [(not b) - ;; Ideally, this would count as an error that we can fix. It seems that we - ;; don't always have enough control to use the right eventspace with an - ;; unfreeze point, though, so just bail out with the default. - #; - (internal-error (format "constrained-reply not within an unfreeze point for ~s" - thunk)) - fail-result] - [(not (eq? (current-thread) (eventspace-handler-thread es))) - (internal-error "wrong eventspace for constrained event handling\n") - default] - [(pair? (unbox b)) - ;; already suspended, so push this work completely: - (set-box! b (cons thunk (unbox b))) - default] - [else - ;; try to do some work: - (let* ([prev #f] - [ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) - (scheme_call_with_composable_no_dws - (lambda (proc) - (set-box! b (cons proc (unbox b))) - (scheme_restore_on_atomic_timeout prev) - (scheme_abort_continuation_no_dws - freeze-tag - (lambda () default))) - freeze-tag) - (void)))]) - (with-holding - handler - (call-with-continuation-prompt ; to catch aborts - (lambda () - (call-with-continuation-prompt ; for composable continuation - (lambda () - (set! prev (scheme_set_on_atomic_timeout handler)) - (set! ready? #t) - (dynamic-wind - void - (lambda () - (parameterize ([freezer-box #f]) - (thunk))) - (lambda () - (scheme_restore_on_atomic_timeout prev)))) - freeze-tag)))))]))) + (cond + [(not (can-try-atomic?)) + ;; Ideally, this would count as an error that we can fix. It seems that we + ;; don't always have enough control to use the right eventspace with a + ;; retry point, though, so just bail out with the default. + #; + (internal-error (format "constrained-reply not within an unfreeze point for ~s" + thunk)) + fail-result] + [(not (eq? (current-thread) (eventspace-handler-thread es))) + (internal-error "wrong eventspace for constrained event handling\n") + fail-result] + [else + (try-atomic thunk default)])) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e7d5bd63..3f22945e 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -140,15 +140,17 @@ [(< am bm) -1] [else 1])))) +(define current-cb-box (make-parameter #f)) (define-mz scheme_add_managed (_fun _racket ; custodian _racket ; object - (_fun #:atomic? #t _racket _pointer -> _void) - _pointer ; data + (_fun #:atomic? #t #:keep (lambda (v) (set-box! (current-cb-box) v)) + _racket _racket -> _void) + _racket ; data _int ; strong? -> _pointer)) -(define (shutdown-eventspace! e ignored-data) +(define (shutdown-eventspace! e ignored) (unless (eventspace-shutdown? e) (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) @@ -268,12 +270,14 @@ frames (semaphore-peek-evt done-sema) #f - done-sema)]) - (scheme_add_managed (current-custodian) - e - shutdown-eventspace! - #f - 1) + done-sema)] + [cb-box (box #f)]) + (parameterize ([current-cb-box cb-box]) + (scheme_add_managed (current-custodian) + e + shutdown-eventspace! + cb-box ; retain callback until it's called + 1)) e))) (define main-eventspace (make-eventspace* (current-thread))) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index ef552b4c..7f633906 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -108,7 +108,7 @@ => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () - (call-as-unfreeze-point + (call-as-nonatomic-retry-point (lambda () (gtk_main_do_event evt) (gdk_event_free evt)))))))] From 5f125ac987e5ad9823a02d837a764b49c199eb82 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Aug 2010 06:06:50 -0600 Subject: [PATCH 151/462] fix gobj vs. glib imports original commit: b6a31a2d7d0bd52698b755b3ddab020d328747ee --- collects/mred/private/wx/gtk/utils.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 4efd0433..6e4c4664 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -82,7 +82,7 @@ (define-gobj g_object_ref (_fun _pointer -> _void)) (define-gobj g_object_unref (_fun _pointer -> _void)) -(define-gobj g_free (_fun _pointer -> _void)) +(define-glib g_free (_fun _pointer -> _void)) (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) @@ -136,7 +136,7 @@ ([data _pointer] [next (_or-null _g-slist-pointer)])) -(define-gobj g_slist_free (_fun _g-slist-pointer -> _void)) +(define-glib g_slist_free (_fun _g-slist-pointer -> _void)) ;; This should probably be provided by Racket (define make-byte-string (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket))) From 2345694b63a6ef9dc8caffd529f5ba35c1ea6a10 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Aug 2010 16:43:57 -0400 Subject: [PATCH 152/462] more fixes to work with older Gtk version original commit: 00f2385cd4d438fb4f61405aa217baf2e6ada539 --- collects/mred/private/wx/gtk/canvas.rkt | 66 ++++++++++++++++++---- collects/mred/private/wx/gtk/clipboard.rkt | 18 +++++- collects/mred/private/wx/gtk/menu.rkt | 1 - collects/mred/private/wx/gtk/utils.rkt | 5 +- collects/mred/private/wx/gtk/window.rkt | 18 +++++- 5 files changed, 91 insertions(+), 17 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 5609d9d3..586e34cf 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -7,6 +7,7 @@ racket/draw/local "../common/backing-dc.rkt" "../../syntax.rkt" + "../../lock.rkt" "../common/event.rkt" "utils.rkt" "const.rkt" @@ -21,6 +22,15 @@ ;; ---------------------------------------- +(define-gobj g_object_freeze_notify (_fun _GtkWidget -> _void)) +(define-gobj g_object_thaw_notify (_fun _GtkWidget -> _void)) + +(define-gobj g_object_set_double (_fun _GtkWidget _string _double* (_pointer = #f) -> _void) + #:c-id g_object_set) +(define-gobj g_object_get_double (_fun _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f) + -> _void -> r) + #:c-id g_object_get) + (define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) @@ -33,15 +43,47 @@ (define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject (define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment)) -(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void)) +(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void) + #:fail (lambda () + ;; This by-hand version doesn't produce quite the same notifications. + (lambda (gtk value lower upper step-inc page-inc page-size) + (as-entry + (lambda () + (g_object_freeze_notify gtk) + (g_object_set_double gtk "lower" lower) + (g_object_set_double gtk "upper" upper) + (g_object_set_double gtk "step-increment" step-inc) + (g_object_set_double gtk "page-increment" page-inc) + (g_object_set_double gtk "page-size" page-size) + (let ([value (max lower (min value (- upper page-size)))]) + (gtk_adjustment_set_value gtk value)) + (g_object_thaw_notify gtk)))))) (define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*)) (define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void)) -(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*)) -(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void)) -(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*)) -(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void)) -(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)) -(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "upper")))) +(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk upper) + (g_object_set_double gtk "upper" upper)))) +(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "page-size")))) +(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk page-size) + (g_object_set_double gtk "page-size" page-size)))) +(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "page-increment")))) +(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk page-inc) + (g_object_set_double gtk "page-increment" page-inc)))) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) @@ -69,7 +111,7 @@ (define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null)) (define-gdk gdk_window_hide (_fun _pointer -> _void)) (define (get-subwindow gtk) - (let* ([win (g_object_get_window gtk)] + (let* ([win (widget-window gtk)] [subs (gdk_window_get_children win)]) (if subs (GList-data subs) @@ -91,14 +133,14 @@ (unless (send wx paint-or-queue-paint) (let ([gc (send wx get-canvas-background-for-clearing)]) (when gc - (gdk_draw_rectangle (g_object_get_window gtk) gc #t + (gdk_draw_rectangle (widget-window gtk) gc #t 0 0 32000 32000))))) #t)) (define-signal-handler connect-expose-border "expose-event" (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (lambda (gtk event) - (let* ([win (g_object_get_window gtk)] + (let* ([win (widget-window gtk)] [gc (gdk_gc_new win)] [gray #x8000]) (when gc @@ -292,7 +334,7 @@ (define/public (paint-or-queue-paint) (or (do-backing-flush this dc (if is-combo? (get-subwindow client-gtk) - (g_object_get_window client-gtk))) + (widget-window client-gtk))) (begin (queue-paint) #f))) @@ -446,7 +488,7 @@ (if clear-bg? (let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) (unless gc - (let ([w (g_object_get_window gtk)]) + (let ([w (widget-window gtk)]) (set! gc (gdk_gc_new w)))) (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 (conv (color-red bg-col)) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index c2f0e3e8..075890b9 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -19,6 +19,18 @@ (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) +;; Recent versions of Gtk provide function calls to +;; access data, but use structure when the functions are +;; not available +(define-cstruct _GtkSelectionDataT ([selection _GdkAtom] + [target _GdkAtom] + [type _GdkAtom] + [format _int] + [data _pointer] + [length _int] + [display _GtkDisplay])) + + (define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom)) (define-gtk gtk_clipboard_get (_fun _GdkAtom -> _GtkClipboard)) @@ -34,8 +46,10 @@ -> _void)) (define-gtk gtk_clipboard_wait_for_contents (_fun _GtkClipboard _GdkAtom -> (_or-null _GtkSelectionData))) (define-gtk gtk_selection_data_free (_fun _GtkSelectionData -> _void)) -(define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int)) -(define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer)) +(define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int) + #:fail (lambda () GtkSelectionDataT-length)) +(define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer) + #:fail (lambda () GtkSelectionDataT-data)) (define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _string)) (define-cstruct _GtkTargetEntry ([target _pointer] diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 4e2232b6..d3ef2afd 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -21,7 +21,6 @@ (define-gtk gtk_accel_map_add_entry (_fun _string _uint _int -> _void)) (define-gtk gtk_check_menu_item_set_active (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean)) -(define-gtk gtk_menu_item_set_label (_fun _GtkWidget _string -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 6e4c4664..43435a2d 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -30,7 +30,10 @@ get-gtk-object-flags set-gtk-object-flags! - define-signal-handler) + define-signal-handler + + ;; for declaring derived structures: + _GtkObject) (define gdk-lib (case (system-type) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index c3b726d6..1bf5c8b2 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -32,7 +32,9 @@ do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer - (struct-out GtkAllocation) _GtkAllocation-pointer) + (struct-out GtkAllocation) _GtkAllocation-pointer + + widget-window) ;; ---------------------------------------- @@ -58,6 +60,20 @@ (define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) +(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])) + +(define (widget-window gtk) + (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) + ;; ---------------------------------------- (define-signal-handler connect-focus-in "focus-in-event" From 08646c691e78dbf89a38f544bdec777626c32f76 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Aug 2010 14:44:49 -0600 Subject: [PATCH 153/462] have container retain shown children original commit: fdf38124a50108d2310ee600803656f0d791f774 --- collects/mred/private/wx/gtk/canvas.rkt | 7 ++----- collects/mred/private/wx/gtk/frame.rkt | 9 +++++++++ collects/mred/private/wx/gtk/panel.rkt | 7 +------ collects/mred/private/wx/gtk/window.rkt | 22 +++++++++++++--------- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 586e34cf..b847499e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -179,7 +179,7 @@ [gl-config #f]) (inherit get-gtk set-size get-size get-client-size - on-size register-as-child get-top-win + on-size get-top-win set-auto-size adjust-client-delta) (define is-combo? (memq 'combo style)) @@ -347,12 +347,9 @@ (define/public (queue-backing-flush) (gtk_widget_queue_draw client-gtk)) - (define/public (reset-child-dcs) + (define/override (reset-child-dcs) (when (dc . is-a? . dc%) (reset-dc))) - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?) - (when on? (reset-child-dcs))) (send dc start-backing-retained) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 36d2a531..64b1e7e4 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -228,6 +228,15 @@ "eventspace has been shutdown")) (super show on?)) + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child)) + (define/override (register-child-in-parent on?) + (void)) + (define/override (direct-show on?) (super direct-show on?) (register-frame-shown this on?)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 0fd06faa..5a54ed8b 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -17,7 +17,6 @@ (define (panel-mixin %) (class % - (inherit register-as-child) (define lbl-pos 'horizontal) (define children null) @@ -27,7 +26,7 @@ (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) - (define/public (reset-child-dcs) + (define/override (reset-child-dcs) (when (pair? children) (for ([child (in-list children)]) (send child reset-child-dcs)))) @@ -35,10 +34,6 @@ (define/override (set-size x y w h) (super set-size x y w h) (reset-child-dcs)) - - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?) - (when on? (reset-child-dcs))) (define/override (register-child child on?) (let ([now-on? (and (memq child children) #t)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 1bf5c8b2..e6da632d 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -3,6 +3,7 @@ racket/class ffi/unsafe/atomic "../../syntax.rkt" + "../../lock.rkt" "../common/event.rkt" "../common/freeze.rkt" "../common/queue.rkt" @@ -370,13 +371,17 @@ (define shown? #f) (define/public (direct-show on?) - (if on? - (gtk_widget_show gtk) - (gtk_widget_hide gtk)) - (set! shown? (and on? #t)) - (maybe-register-as-child parent on?)) + (as-entry + (lambda () + (if on? + (gtk_widget_show gtk) + (gtk_widget_hide gtk)) + (set! shown? (and on? #t)) + (register-child-in-parent on?))) + (when on? (reset-child-dcs))) (define/public (show on?) (direct-show on?)) + (define/public (reset-child-dcs) (void)) (define/public (is-shown?) shown?) (define/public (is-shown-to-root?) (and shown? @@ -454,12 +459,11 @@ (define/public (on-size w h) (void)) - (define/public (maybe-register-as-child parent on?) - (void)) - (define/public (register-as-child parent on?) - (send parent register-child this on?)) (define/public (register-child child on?) (void)) + (define/public (register-child-in-parent on?) + (when parent + (send parent register-child this on?))) (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) From 91c250cfc5deee2ed383cdd190acf83517636348 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 13 Aug 2010 16:40:26 -0600 Subject: [PATCH 154/462] make platform-to-wx links weak original commit: 0a9bdc11ad7758d04e1f5dc6eb47e8b02ecc27a4 --- collects/mred/private/wx/cocoa/button.rkt | 8 +- collects/mred/private/wx/cocoa/canvas.rkt | 91 ++++---- collects/mred/private/wx/cocoa/choice.rkt | 4 +- collects/mred/private/wx/cocoa/frame.rkt | 63 +++--- collects/mred/private/wx/cocoa/gauge.rkt | 2 +- .../mred/private/wx/cocoa/group-panel.rkt | 2 +- collects/mred/private/wx/cocoa/list-box.rkt | 24 ++- collects/mred/private/wx/cocoa/menu-item.rkt | 9 +- collects/mred/private/wx/cocoa/message.rkt | 4 +- collects/mred/private/wx/cocoa/radio-box.rkt | 4 +- collects/mred/private/wx/cocoa/slider.rkt | 14 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 4 +- collects/mred/private/wx/cocoa/utils.rkt | 10 +- collects/mred/private/wx/cocoa/window.rkt | 170 ++++++++------- collects/mred/private/wx/gtk/button.rkt | 3 +- collects/mred/private/wx/gtk/canvas.rkt | 17 +- collects/mred/private/wx/gtk/choice.rkt | 3 +- .../mred/private/wx/gtk/client-window.rkt | 11 +- collects/mred/private/wx/gtk/frame.rkt | 23 ++- collects/mred/private/wx/gtk/list-box.rkt | 3 +- collects/mred/private/wx/gtk/menu-bar.rkt | 17 +- collects/mred/private/wx/gtk/menu.rkt | 6 +- collects/mred/private/wx/gtk/radio-box.rkt | 3 +- collects/mred/private/wx/gtk/slider.rkt | 3 +- collects/mred/private/wx/gtk/tab-panel.rkt | 3 +- collects/mred/private/wx/gtk/widget.rkt | 6 +- collects/mred/private/wx/gtk/window.rkt | 195 +++++++++--------- 27 files changed, 396 insertions(+), 306 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 5cf3a558..466382e8 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -25,9 +25,9 @@ (define-objc-class MyButton NSButton #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] (-a _void (clicked: [_id sender]) - (queue-window-event wx (lambda () (send wx clicked))))) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) (defclass core-button% item% (init parent cb label x y w h style font @@ -99,10 +99,12 @@ (tellv button-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize new-width new-height))) - (set-ivar! button-cocoa wx this) + (set-ivar! button-cocoa wxb (->wxb this)) cocoa)) button-cocoa)) + (define we (make-will-executor)) + (super-new [parent parent] [cocoa cocoa] [no-show? (memq 'deleted style)] diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 3ca578d1..3faad655 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -28,37 +28,48 @@ (import-protocol NSComboBoxDelegate) ;; Called when a canvas has no backing store ready -(define (clear-background wx) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState))))) +(define (clear-background wxb) + (let ([wx (->wx wxb)]) + (when wx + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState))))))) (define-objc-class MyView NSView #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] (-a _void (drawRect: [_NSRect r]) - (unless (send wx paint-or-queue-paint) - (clear-background wx) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event))) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (unless (send wx paint-or-queue-paint) + (clear-background wxb) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))))) (-a _void (viewWillMoveToWindow: [_id w]) - (when wx - (queue-window-event wx (lambda () (send wx fix-dc))))) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc))))))) (-a _void (onHScroll: [_id scroller]) - (when wx (send wx do-scroll 'horizontal scroller))) + (when wxb + (let ([wx (->wx wxb)]) + (when wx (send wx do-scroll 'horizontal scroller))))) (-a _void (onVScroll: [_id scroller]) - (when wx (send wx do-scroll 'vertical scroller)))) + (when wxb + (let ([wx (->wx wxb)]) + (when wx (send wx do-scroll 'vertical scroller)))))) (define-objc-class FrameView NSView [] @@ -118,22 +129,30 @@ (define-objc-class MyComboBox NSComboBox #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSComboBoxDelegate) - [wx] + [wxb] (-a _void (drawRect: [_NSRect r]) (super-tell #:type _void drawRect: #:type _NSRect r) - (unless (send wx paint-or-queue-paint) - (unless (send wx during-menu-click?) - (clear-background wx) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event)))) + (let ([wx (->wx wxb)]) + (when wx + (unless (send wx paint-or-queue-paint) + (unless (send wx during-menu-click?) + (clear-background wxb) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))))) (-a _void (comboBoxWillPopUp: [_id notification]) - (send wx starting-combo)) + (let ([wx (->wx wxb)]) + (when wx + (send wx starting-combo)))) (-a _void (comboBoxWillDismiss: [_id notification]) - (send wx ending-combo)) + (let ([wx (->wx wxb)]) + (when wx + (send wx ending-combo)))) (-a _void (viewWillMoveToWindow: [_id w]) - (when wx - (queue-window-event wx (lambda () (send wx fix-dc)))))) - + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc)))))))) + (define-struct scroller (cocoa [range #:mutable] [page #:mutable])) (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) @@ -247,7 +266,7 @@ (tell (tell (if is-combo? MyComboBox MyView) alloc) initWithFrame: #:type _NSRect r)))) (tell #:type _void cocoa addSubview: content-cocoa) - (set-ivar! content-cocoa wx this) + (set-ivar! content-cocoa wxb (->wxb this)) (when is-combo? (tellv content-cocoa setEditable: #:type _BOOL #f) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index e94fc82b..71b79707 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -20,9 +20,9 @@ (define-objc-class MyPopUpButton NSPopUpButton #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] (-a _void (clicked: [_id sender]) - (queue-window-event wx (lambda () (send wx clicked))))) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) (defclass choice% item% (init parent cb label diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 660a13a0..39b18c8d 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -30,49 +30,56 @@ (define dialog-level-counter 0) (define-objc-mixin (MyWindowMethods Superclass) - [wx] + [wxb] [-a _scheme (getEventspace) - (send wx get-eventspace)] + (let ([wx (->wx wxb)]) + (and wx (send wx get-eventspace)))] [-a _BOOL (canBecomeKeyWindow) - (not (other-modal? wx))] + (let ([wx (->wx wxb)]) + (and wx + (not (other-modal? wx))))] [-a _BOOL (canBecomeMainWindow) #t] [-a _BOOL (windowShouldClose: [_id win]) - (queue-window-event wx (lambda () - (unless (other-modal? wx) - (when (send wx on-close) - (send wx direct-show #f))))) + (queue-window*-event wxb (lambda (wx) + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f))))) #f] [-a _void (windowDidResize: [_id notification]) - (when wx - (queue-window-event wx (lambda () - (send wx on-size 0 0) - (send wx clean-up))))] + (when wxb + (queue-window*-event wxb (lambda (wx) + (send wx on-size 0 0) + (send wx clean-up))))] [-a _void (windowDidMove: [_id notification]) - (when wx - (queue-window-event wx (lambda () - (send wx on-size 0 0))))] + (when wxb + (queue-window*-event wxb (lambda (wx) + (send wx on-size 0 0))))] [-a _void (windowDidBecomeMain: [_id notification]) - (when wx - (set! front wx) - (send wx install-mb) - (send wx notify-responder #t) - (queue-window-event wx (lambda () - (send wx on-activate #t))))] + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (set! front wx) + (send wx install-mb) + (send wx notify-responder #t) + (queue-window-event wx (lambda () + (send wx on-activate #t))))))] [-a _void (windowDidResignMain: [_id notification]) - (when wx - (when (eq? front wx) (set! front #f)) - (send empty-mb install) - (send wx notify-responder #f) - (queue-window-event wx (lambda () - (send wx on-activate #f))))]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (when (eq? front wx) (set! front #f)) + (send empty-mb install) + (send wx notify-responder #f) + (queue-window-event wx (lambda () + (send wx on-activate #f))))))]) (define-objc-class MyWindow NSWindow #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) - [wx]) + [wxb]) (define-objc-class MyPanel NSPanel #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) - [wx]) + [wxb]) (set-front-hook! (lambda () (values front (and front (send front get-eventspace))))) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index db13bb78..32241caa 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -19,7 +19,7 @@ (define-objc-class MyProgressIndicator NSProgressIndicator #:mixins () - [wx]) + [wxb]) (defclass gauge% item% (init parent diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index 73588a0a..0b367e47 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -16,7 +16,7 @@ (define-objc-class MyBox NSBox #:mixins (FocusResponder KeyMouseResponder) - [wx]) + [wxb]) (defclass group-panel% (panel-mixin window%) (init parent diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 7fda6f6e..434ef4b8 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -23,23 +23,29 @@ (define-objc-class MyTableView NSTableView #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) - (tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))] + (let ([wx (->wx wxb)]) + (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???")))] [-a _void (doubleClicked: [_id sender]) - (queue-window-event wx (lambda () (send wx clicked 'list-box-dclick)))] + (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] [-a _void (tableViewSelectionDidChange: [_id aNotification]) - (queue-window-event wx (lambda () (send wx clicked 'list-box)))]) + (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))]) (define-objc-class MyDataSource NSObject #:protocols (NSTableViewDataSource) - [wx] + [wxb] [-a _NSInteger (numberOfRowsInTableView: [_id view]) - (send wx number)] + (let ([wx (->wx wxb)]) + (send wx number))] [-a _NSString (tableView: [_id aTableView] objectValueForTableColumn: [_id aTableColumn] row: [_NSInteger rowIndex]) - (send wx get-row rowIndex)]) + (let ([wx (->wx wxb)]) + (if wx + (send wx get-row rowIndex) + "???"))]) (define (remove-nth data i) (cond @@ -55,7 +61,7 @@ (define source (as-objc-allocation (tell (tell MyDataSource alloc) init))) - (set-ivar! source wx this) + (set-ivar! source wxb (->wxb this)) (define items choices) (define data (map (lambda (x) (box #f)) choices)) @@ -73,7 +79,7 @@ (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))) (init-font content-cocoa font) content-cocoa)) - (set-ivar! content-cocoa wx this) + (set-ivar! content-cocoa wxb (->wxb this)) (tellv cocoa setDocumentView: content-cocoa) (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 29365d24..2e532ebb 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -14,8 +14,11 @@ (import-class NSMenuItem) (define-objc-class MyMenuItem NSMenuItem - [wx] - (-a _void (selected: [_id sender]) (send wx selected))) + [wxb] + (-a _void (selected: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx + (send wx selected))))) (defclass menu-item% object% @@ -51,7 +54,7 @@ initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") action: #:type _SEL #f keyEquivalent: #:type _NSString "")]) - (set-ivar! item wx this) + (set-ivar! item wxb (->wxb this)) (tellv menu addItem: item) (tellv item setEnabled: #:type _BOOL enabled?) (tellv item setTarget: item) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 68d5cc44..0fce8fc5 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -33,11 +33,11 @@ (define-objc-class MyTextField NSTextField #:mixins (FocusResponder KeyMouseResponder) - [wx]) + [wxb]) (define-objc-class MyImageView NSImageView #:mixins (FocusResponder KeyMouseResponder) - [wx]) + [wxb]) (defclass message% item% (init parent label diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 211410e6..fce42e5c 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -25,9 +25,9 @@ (define-objc-class MyMatrix NSMatrix #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] (-a _void (clicked: [_id sender]) - (queue-window-event wx (lambda () (send wx clicked))))) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) (define-objc-class MyImageButtonCell NSButtonCell [img] diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index c0a8e780..92dd980a 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -23,13 +23,15 @@ (define-objc-class MySlider NSSlider #:mixins (FocusResponder KeyMouseResponder) - [wx] + [wxb] (-a _void (changed: [_id sender]) - (queue-window-event wx (lambda () (send wx changed))) - (constrained-reply - (send wx get-eventspace) - (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) - (void)))) + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () (send wx changed))) + (constrained-reply + (send wx get-eventspace) + (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))))) (defclass slider% item% (init parent cb diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 175e4d40..9a11f8a4 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -20,9 +20,9 @@ (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSTabViewDelegate) - [wx] + [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) - (queue-window-event wx (lambda () (send wx do-callback))))) + (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) (defclass tab-panel% (panel-mixin window%) (init parent diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 132b691f..72167b6c 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -14,7 +14,9 @@ as-objc-allocation retain release with-autorelease - clean-menu-label) + clean-menu-label + ->wxb + ->wx) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) @@ -50,3 +52,9 @@ (define (clean-menu-label str) (regexp-replace* #rx"&(.)" str "\\1")) + +(define (->wxb wx) + (make-weak-box wx)) + +(define (->wx wxb) + (weak-box-value wxb)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 0796b38c..9361147c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -21,6 +21,7 @@ KeyMouseResponder queue-window-event + queue-window*-event request-flush-delay cancel-flush-delay) @@ -29,30 +30,30 @@ ;; ---------------------------------------- (define-objc-mixin (FocusResponder Superclass) - [wx] + [wxb] [-a _BOOL (acceptsFirstResponder) #t] [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) - (begin - (send wx is-responder wx #t) + (let ([wx (->wx wxb)]) + (when wx (send wx is-responder wx #t)) #t))] [-a _BOOL (resignFirstResponder) (and (super-tell resignFirstResponder) - (begin - (send wx is-responder wx #f) + (let ([wx (->wx wxb)]) + (when wx (send wx is-responder wx #f)) #t))]) (define-objc-mixin (KeyMouseResponder Superclass) - [wx] + [wxb] [-a _void (mouseDown: [_id event]) - (unless (do-mouse-event wx event 'left-down #t #f #f 'right-down) + (unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down) (super-tell #:type _void mouseDown: event))] [-a _void (mouseUp: [_id event]) - (unless (do-mouse-event wx event 'left-up #f #f #f 'right-up) + (unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up) (super-tell #:type _void mouseUp: event))] [-a _void (mouseDragged: [_id event]) - (unless (do-mouse-event wx event 'motion #t #f #f) + (unless (do-mouse-event wxb event 'motion #t #f #f) (super-tell #:type _void mouseDragged: event))] [-a _void (mouseMoved: [_id event]) ;; This event is sent to the first responder, instead of the @@ -69,94 +70,102 @@ (loop (tell hit superview))))))] [-a _BOOL (doMouseMoved: [_id event]) ;; called by mouseMoved: - (do-mouse-event wx event 'motion #f #f #f)] + (do-mouse-event wxb event 'motion #f #f #f)] [-a _void (mouseEntered: [_id event]) - (unless (do-mouse-event wx event 'enter #f #f #f) + (unless (do-mouse-event wxb event 'enter #f #f #f) (super-tell #:type _void mouseEntered: event))] [-a _void (mouseExited: [_id event]) - (unless (do-mouse-event wx event 'leave #f #f #f) + (unless (do-mouse-event wxb event 'leave #f #f #f) (super-tell #:type _void mouseExited: event))] [-a _void (rightMouseDown: [_id event]) - (unless (do-mouse-event wx event 'right-down #f #f #t) + (unless (do-mouse-event wxb event 'right-down #f #f #t) (super-tell #:type _void rightMouseDown: event))] [-a _void (rightMouseUp: [_id event]) - (unless (do-mouse-event wx event 'right-up #f #f #f) + (unless (do-mouse-event wxb event 'right-up #f #f #f) (super-tell #:type _void rightMouseUp: event))] [-a _void (rightMouseDragged: [_id event]) - (unless (do-mouse-event wx event 'motion #f #f #t) + (unless (do-mouse-event wxb event 'motion #f #f #t) (super-tell #:type _void rightMouseDragged: event))] [-a _void (otherMouseDown: [_id event]) - (unless (do-mouse-event wx event 'middle-down #f #t #f) + (unless (do-mouse-event wxb event 'middle-down #f #t #f) (super-tell #:type _void otherMouseDown: event))] [-a _void (otherMouseUp: [_id event]) - (unless (do-mouse-event wx event 'middle-up #f #f #f) + (unless (do-mouse-event wxb event 'middle-up #f #f #f) (super-tell #:type _void otherMouseUp: event))] [-a _void (otherMouseDragged: [_id event]) - (unless (do-mouse-event wx event 'motion #f #t #f) + (unless (do-mouse-event wxb event 'motion #f #t #f) (super-tell #:type _void otherMouseDragged: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wx event) + (unless (do-key-event wxb event) (super-tell #:type _void keyDown: event))] [-a _void (insertText: [_NSString str]) - (queue-window-event wx (lambda () - (send wx key-event-as-string str)))]) + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () + (send wx key-event-as-string str)))))]) -(define (do-key-event wx event) - (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] - [bit? (lambda (m b) (positive? (bitwise-and m b)))] - [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)]) - (let-values ([(x y) (send wx window-point-to-view pos)]) - (let ([k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (string-ref str 0)))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [x (->long x)] - [y (->long y)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx definitely-wants-event? k) - (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 (do-key-event wxb event) + (let ([wx (->wx wxb)]) + (and + wx + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)] + [str (tell #:type _NSString event characters)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (string-ref str 0)))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx definitely-wants-event? k) + (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 (do-mouse-event wx event kind l? m? r? [ctl-kind kind]) - (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] - [bit? (lambda (m b) (positive? (bitwise-and m b)))] - [pos (tell #:type _NSPoint event locationInWindow)]) - (let-values ([(x y) (send wx window-point-to-view pos)] - [(control-down) (bit? modifiers NSControlKeyMask)]) - (let ([m (new mouse-event% - [event-type (if control-down ctl-kind kind)] - [left-down (and l? (not control-down))] - [middle-down m?] - [right-down (or r? (and l? control-down))] - [x (->long x)] - [y (->long y)] - [shift-down (bit? modifiers NSShiftKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx definitely-wants-event? m) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))))) +(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) + (let ([wx (->wx wxb)]) + (and + wx + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)]) + (let-values ([(x y) (send wx window-point-to-view pos)] + [(control-down) (bit? modifiers NSControlKeyMask)]) + (let ([m (new mouse-event% + [event-type (if control-down ctl-kind kind)] + [left-down (and l? (not control-down))] + [middle-down m?] + [right-down (or r? (and l? control-down))] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx definitely-wants-event? m) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))))))) (define window% (class object% @@ -173,7 +182,7 @@ (when (eventspace-shutdown? eventspace) (error '|GUI object initialization| "the eventspace has been shutdown")) - (set-ivar! cocoa wx this) + (set-ivar! cocoa wxb (->wxb this)) (unless no-show? (show #t)) @@ -392,8 +401,13 @@ ;; ---------------------------------------- -(define (queue-window-event win thunk) - (queue-event (send win get-eventspace) thunk)) +(define (queue-window-event wx thunk) + (queue-event (send wx get-eventspace) thunk)) + +(define (queue-window*-event wxb proc) + (let ([wx (->wx wxb)]) + (when wx + (queue-event (send wx get-eventspace) (lambda () (proc wx)))))) (define depth 0) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 8277ffe0..41a0388d 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -29,7 +29,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx queue-clicked)))) + (when wx + (send wx queue-clicked))))) (defclass button-core% item% (init parent cb label x y w h style font diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index b847499e..cf625f6e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -121,7 +121,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx combo-maybe-clicked)))) + (when wx + (send wx combo-maybe-clicked))))) (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) @@ -130,11 +131,12 @@ (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (unless (send wx paint-or-queue-paint) - (let ([gc (send wx get-canvas-background-for-clearing)]) - (when gc - (gdk_draw_rectangle (widget-window gtk) gc #t - 0 0 32000 32000))))) + (when wx + (unless (send wx paint-or-queue-paint) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (widget-window gtk) gc #t + 0 0 32000 32000)))))) #t)) (define-signal-handler connect-expose-border "expose-event" @@ -165,7 +167,8 @@ (define (do-value-changed gtk dir) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx do-scroll dir)))) + (when wx + (queue-window-event wx (lambda () (send wx do-scroll dir))))) #t) (define-gtk gtk_entry_get_type (_fun -> _GType)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ce69a648..3f1238e8 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -26,7 +26,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx queue-clicked)))) + (when wx + (send wx queue-clicked))))) (defclass choice% item% (init parent cb label diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 79b562a3..5c34d43c 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -17,11 +17,12 @@ (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) (lambda (gtk a) (let ([wx (gtk->wx gtk)]) - (send wx save-client-size - (GtkAllocation-x a) - (GtkAllocation-y a) - (GtkAllocation-width a) - (GtkAllocation-height a))) + (when wx + (send wx save-client-size + (GtkAllocation-x a) + (GtkAllocation-y a) + (GtkAllocation-width a) + (GtkAllocation-height a)))) #t)) (define (client-size-mixin %) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 64b1e7e4..3ba10a7c 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -56,18 +56,20 @@ (_fun _GtkWidget -> _gboolean) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () - (unless (other-modal? wx) - (when (send wx on-close) - (send wx direct-show #f)))))))) + (when wx + (queue-window-event wx (lambda () + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f))))))))) (define-signal-handler connect-configure "configure-event" (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) (lambda (gtk a) (let ([wx (gtk->wx gtk)]) - (send wx remember-size - (GdkEventConfigure-width a) - (GdkEventConfigure-height a))) + (when wx + (send wx remember-size + (GdkEventConfigure-width a) + (GdkEventConfigure-height a)))) #f)) (define-cstruct _GdkEventWindowState ([type _int] @@ -81,9 +83,10 @@ (_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean) (lambda (gtk evt) (let ([wx (gtk->wx gtk)]) - (send wx on-window-state - (GdkEventWindowState-changed_mask evt) - (GdkEventWindowState-new_window_state evt))) + (when wx + (send wx on-window-state + (GdkEventWindowState-changed_mask evt) + (GdkEventWindowState-new_window_state evt)))) #f)) (define frame% diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 4544f778..7e4f7f28 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -62,7 +62,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx queue-changed)))) + (when wx + (send wx queue-changed))))) (defclass list-box% item% (init parent cb diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index b1afb74a..a51a944a 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -41,11 +41,12 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (let ([frame (send wx get-top-window)]) - (when frame - (constrained-reply (send frame get-eventspace) - (lambda () (send frame on-menu-click)) - (void))))))) + (when wx + (let ([frame (send wx get-top-window)]) + (when frame + (constrained-reply (send frame get-eventspace) + (lambda () (send frame on-menu-click)) + (void)))))))) (define top-menu% (class widget% @@ -57,13 +58,15 @@ (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (other-modal? wx)))) + (or (not wx) + (other-modal? wx))))) (define-signal-handler connect-menu-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (other-modal? wx)))) + (or (not wx) + (other-modal? wx))))) (defclass menu-bar% widget% (inherit install-widget-parent) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index d3ef2afd..0698d6a4 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -36,13 +36,15 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx do-on-select)))) + (when wx + (send wx do-on-select))))) (define-signal-handler connect-menu-deactivate "deactivate" (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx do-no-selected)))) + (when wx + (send wx do-no-selected))))) (define menu-item-handler% (class widget% diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 68285a9d..e1c20879 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -31,7 +31,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx queue-clicked)))) + (when wx + (send wx queue-clicked))))) (defclass radio-box% item% (init parent cb label diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 2ed4cc2e..d2280ef3 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -26,7 +26,8 @@ (_fun _GtkWidget -> _void) (lambda (gtk) (let ([wx (gtk->wx gtk)]) - (send wx queue-changed)))) + (when wx + (send wx queue-changed))))) (defclass slider% item% (init parent cb diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 8e1bc1b6..c2e304e9 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -35,7 +35,8 @@ (_fun _GtkWidget _pointer _int -> _void) (lambda (gtk ignored i) (let ([wx (gtk->wx gtk)]) - (send wx page-changed i)))) + (when wx + (send wx page-changed i))))) (define tab-panel% (class (client-size-mixin (panel-mixin window%)) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index a836f516..cf407082 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -52,14 +52,16 @@ (super-new) - (let ([cell (malloc-immobile-cell this)]) + (let ([cell (malloc-immobile-cell (make-weak-box this))]) (g_object_set_data gtk "wx" cell) (for ([gtk (in-list extra-gtks)]) (g_object_set_data gtk "wx" cell))))) (define (gtk->wx gtk) (let ([ptr (g_object_get_data gtk "wx")]) - (and ptr (ptr-ref ptr _scheme)))) + (and ptr + (let ([wb (ptr-ref ptr _scheme)]) + (and wb (weak-box-value wb)))))) (set-widget-hook! (lambda (gtk) (let loop ([gtk gtk]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e6da632d..a85982a0 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -81,13 +81,15 @@ (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx on-set-focus))) + (when wx + (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) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx on-kill-focus))) + (when wx + (queue-window-event wx (lambda () (send wx on-kill-focus)))) #f))) (define (connect-focus gtk) (connect-focus-in gtk) @@ -97,47 +99,52 @@ (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) (lambda (gtk a) (let ([wx (gtk->wx gtk)]) - (send wx save-size - (GtkAllocation-x a) - (GtkAllocation-y a) - (GtkAllocation-width a) - (GtkAllocation-height a))) + (when wx + (send wx save-size + (GtkAllocation-x a) + (GtkAllocation-y a) + (GtkAllocation-width a) + (GtkAllocation-height a)))) #t)) ;; ---------------------------------------- (define-signal-handler connect-key-press "key-press-event" (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) - (let* ([wx (gtk->wx gtk)] - [modifiers (GdkEventKey-state event)] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [k (new key-event% - [key-code (let ([kv (GdkEventKey-keyval event)]) - (or - (map-key-code kv) - (integer->char (gdk_keyval_to_unicode kv))))] - [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)] - [x 0] - [y 0] - [time-stamp (GdkEventKey-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-char k #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (GdkEventKey-state event)] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [k (new key-event% + [key-code (let ([kv (GdkEventKey-keyval event)]) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [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)] + [x 0] + [y 0] + [time-stamp (GdkEventKey-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-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) (lambda (gtk event) (unless (gtk_widget_is_focus gtk) - (unless (other-modal? (gtk->wx gtk)) - (gtk_widget_grab_focus gtk))) + (let ([wx (gtk->wx gtk)]) + (when wx + (unless (other-modal? wx) + (gtk_widget_grab_focus gtk))))) (do-button-event gtk event #f #f))) (define-signal-handler connect-button-release "button-release-event" @@ -176,67 +183,69 @@ (GdkEventButton-type event)))]) (unless (or (= type GDK_2BUTTON_PRESS) (= type GDK_3BUTTON_PRESS)) - (let* ([wx (gtk->wx gtk)] - [modifiers (if motion? - (GdkEventMotion-state event) - (if crossing? - (GdkEventCrossing-state event) - (GdkEventButton-state event)))] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [type (cond - [(= type GDK_MOTION_NOTIFY) - 'motion] - [(= type GDK_ENTER_NOTIFY) - 'enter] - [(= type GDK_LEAVE_NOTIFY) - 'leave] - [(= type GDK_BUTTON_PRESS) - (case (GdkEventButton-button event) - [(1) 'left-down] - [(3) 'right-down] - [else 'middle-down])] - [else - (case (GdkEventButton-button event) - [(1) 'left-up] - [(3) 'right-up] - [else 'middle-up])])] - [m (new mouse-event% - [event-type type] - [left-down (case type - [(left-down) #t] - [(left-up) #f] - [else (bit? modifiers GDK_BUTTON1_MASK)])] - [middle-down (case type - [(middle-down) #t] - [(middle-up) #f] - [else (bit? modifiers GDK_BUTTON2_MASK)])] - [right-down (case type - [(right-down) #t] - [(right-up) #f] - [else (bit? modifiers GDK_BUTTON3_MASK)])] - [x (->long ((if motion? - GdkEventMotion-x - (if crossing? GdkEventCrossing-x GdkEventButton-x)) - event))] - [y (->long ((if motion? GdkEventMotion-y - (if crossing? GdkEventCrossing-y GdkEventButton-y)) - event))] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_META_MASK)] - [alt-down (bit? modifiers GDK_MOD1_MASK)] - [time-stamp ((if motion? GdkEventMotion-time - (if crossing? GdkEventCrossing-time GdkEventButton-time)) - event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events? gtk) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))))) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (if motion? + (GdkEventMotion-state event) + (if crossing? + (GdkEventCrossing-state event) + (GdkEventButton-state event)))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [type (cond + [(= type GDK_MOTION_NOTIFY) + 'motion] + [(= type GDK_ENTER_NOTIFY) + 'enter] + [(= type GDK_LEAVE_NOTIFY) + 'leave] + [(= type GDK_BUTTON_PRESS) + (case (GdkEventButton-button event) + [(1) 'left-down] + [(3) 'right-down] + [else 'middle-down])] + [else + (case (GdkEventButton-button event) + [(1) 'left-up] + [(3) 'right-up] + [else 'middle-up])])] + [m (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? modifiers GDK_BUTTON1_MASK)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? modifiers GDK_BUTTON2_MASK)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? modifiers GDK_BUTTON3_MASK)])] + [x (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event))] + [y (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event))] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [time-stamp ((if motion? GdkEventMotion-time + (if crossing? GdkEventCrossing-time GdkEventButton-time)) + event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))))))) ;; ---------------------------------------- From 865a4b46718981eee1d6f344a4a521d23b2d9e97 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Aug 2010 09:04:09 -0600 Subject: [PATCH 155/462] clean up lock library and uses original commit: a9ffced9b8537987c584b206d04e824e54ada965 --- collects/mred/private/lock.rkt | 86 +++++++++++---- collects/mred/private/wx/cocoa/canvas.rkt | 1 + collects/mred/private/wx/cocoa/dc.rkt | 25 +++-- collects/mred/private/wx/cocoa/dialog.rkt | 18 ++-- collects/mred/private/wx/cocoa/image.rkt | 45 ++++---- collects/mred/private/wx/cocoa/list-box.rkt | 32 +++--- collects/mred/private/wx/cocoa/procs.rkt | 4 +- collects/mred/private/wx/cocoa/queue.rkt | 2 +- collects/mred/private/wx/cocoa/window.rkt | 44 ++++---- .../mred/private/wx/common/backing-dc.rkt | 19 ++-- collects/mred/private/wx/common/timer.rkt | 12 ++- collects/mred/private/wx/gtk/canvas.rkt | 22 ++-- collects/mred/private/wx/gtk/check-box.rkt | 9 +- collects/mred/private/wx/gtk/choice.rkt | 38 ++++--- collects/mred/private/wx/gtk/dc.rkt | 1 + collects/mred/private/wx/gtk/list-box.rkt | 101 +++++++++--------- collects/mred/private/wx/gtk/pixbuf.rkt | 29 +++-- collects/mred/private/wx/gtk/procs.rkt | 4 +- collects/mred/private/wx/gtk/queue.rkt | 4 +- collects/mred/private/wx/gtk/radio-box.rkt | 21 ++-- collects/mred/private/wx/gtk/slider.rkt | 9 +- collects/mred/private/wx/gtk/window.rkt | 13 ++- 22 files changed, 284 insertions(+), 255 deletions(-) diff --git a/collects/mred/private/lock.rkt b/collects/mred/private/lock.rkt index 21694347..7d50f669 100644 --- a/collects/mred/private/lock.rkt +++ b/collects/mred/private/lock.rkt @@ -1,19 +1,69 @@ -(module lock mzscheme - (require racket/draw/lock) - (provide as-entry - as-exit - entry-point - (protect mk-param)) +#lang racket/base +(require (for-syntax racket/base) + ffi/unsafe/atomic) - (define-syntax mk-param - (lambda (stx) - (syntax-case stx () - [(_ val filter check force-redraw) - (syntax - (case-lambda - [() val] - [(v) (check v) - (let ([v2 (filter v)]) - (unless (eq? v2 val) - (set! val v2) - (force-redraw)))]))])))) +(provide (protect-out as-entry ;; alias for call-as-atomic + as-exit ;; alias for call-as-nonatomic + atomically ;; assumes no exceptions! + entry-point ;; converts a proc body to use as-entry + mk-param)) ;; parameter pattern --- out of place here + +;; We need atomic mode for a couple of reasons: +;; +;; * We may need to bracket some (trusted) operations so that the +;; queue thread doesn't poll for events during the operation. +;; The `atomically' form is ok for that if no exceptions will +;; be raised. Otherwise, use the more heavyweight `as-entry'. +;; +;; * The scheme/gui classes have internal-consistency requirements. +;; When the user creates an object or calls a method, or when the +;; system invokes a callback, many steps may be required to +;; initialize or reset fields to maintain invariants. To ensure that +;; other threads do not call methods during a time when invariants +;; do not hold, we force all of the following code to be executed in +;; a single threaded manner, and we temporarily disable breaks. +;; The `as-entry' form or `entry-point' wrapper is normally used for +;; that case. +;; +;; If an exception is raised within an `enter'ed area, control is +;; moved back outside by the exception handler, and then the exception +;; is re-raised. The user can't tell that the exception was caught an +;; re-raised. But without the catch-and-reraise, the user's exception +;; handler might try to use GUI elements from a different thread, or +;; other such things, leading to deadlock. + +(define as-entry call-as-atomic) + +(define as-exit call-as-nonatomic) + +(define-syntax entry-point + (lambda (stx) + (syntax-case stx (lambda #%plain-lambda case-lambda) + [(_ (lambda args body1 body ...)) + (syntax (lambda args (as-entry (lambda () body1 body ...))))] + [(_ (#%plain-lambda args body1 body ...)) + (syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))] + [(_ (case-lambda [vars body1 body ...] ...)) + (syntax (case-lambda + [vars (as-entry (lambda () body1 body ...))] + ...))]))) + +(define-syntax-rule (atomically expr ...) + (begin + (start-atomic) + (begin0 (let () expr ...) + (end-atomic)))) + +;; Parameter-method pattern. (Why is this in the "lock" library?) +(define-syntax mk-param + (lambda (stx) + (syntax-case stx () + [(_ val filter check force-redraw) + (syntax + (case-lambda + [() val] + [(v) (check v) + (let ([v2 (filter v)]) + (unless (eq? v2 val) + (set! val v2) + (force-redraw)))]))]))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 3faad655..1c4467a1 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -235,6 +235,7 @@ (queue-paint)) (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index bfe3c8c9..2dab797f 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -50,27 +50,26 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) + ;; called atomically (not expecting exceptions) (send canvas queue-backing-flush)) (define suspend-count 0) (define req #f) (define/override (suspend-flush) - (as-entry - (lambda () - (when (zero? suspend-count) - (set! req (request-flush-delay (send canvas get-cocoa-window)))) - (set! suspend-count (add1 suspend-count)) - (super suspend-flush)))) + (atomically + (when (zero? suspend-count) + (set! req (request-flush-delay (send canvas get-cocoa-window)))) + (set! suspend-count (add1 suspend-count)) + (super suspend-flush))) (define/override (resume-flush) - (as-entry - (lambda () - (set! suspend-count (sub1 suspend-count)) - (when (and (zero? suspend-count) req) - (cancel-flush-delay req) - (set! req #f)) - (super resume-flush)))))) + (atomically + (set! suspend-count (sub1 suspend-count)) + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f)) + (super resume-flush))))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 9ebc246f..2e696629 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -14,11 +14,10 @@ (define/override (direct-show on?) (unless on? - (as-entry - (lambda () - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f))))) + (atomically + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f)))) (super direct-show on?)) ;; #t result avoids children sheets @@ -26,11 +25,10 @@ (define/override (show on?) (if on? - (let ([s (as-entry - (lambda () - (let ([s (or close-sema (make-semaphore))]) - (unless close-sema (set! close-sema s)) - s)))]) + (let ([s (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + s))]) (super show on?) (yield s) (void)) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index 4d4de0bd..f95cf7d1 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -60,26 +60,25 @@ (let ([mask (send bm get-loaded-mask)]) (when mask (send mask get-argb-pixels 0 0 w h str #t))) - (as-entry - (lambda () - (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) - (memcpy rgba str (sub1 (* w h 4))) - (let* ([cs (CGColorSpaceCreateDeviceRGB)] - [provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)] - [image (CGImageCreate w - h - 8 - 32 - (* 4 w) - cs - (bitwise-ior kCGImageAlphaFirst - kCGBitmapByteOrder32Big) - provider ; frees `rgba' - #f - #f - 0)]) - (CGDataProviderRelease provider) - (CGColorSpaceRelease cs) - (tell (tell NSImage alloc) - initWithCGImage: #:type _CGImageRef image - size: #:type _NSSize (make-NSSize w h)))))))) + (atomically + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) + (memcpy rgba str (sub1 (* w h 4))) + (let* ([cs (CGColorSpaceCreateDeviceRGB)] + [provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)] + [image (CGImageCreate w + h + 8 + 32 + (* 4 w) + cs + (bitwise-ior kCGImageAlphaFirst + kCGBitmapByteOrder32Big) + provider ; frees `rgba' + #f + #f + 0)]) + (CGDataProviderRelease provider) + (CGColorSpaceRelease cs) + (tell (tell NSImage alloc) + initWithCGImage: #:type _CGImageRef image + size: #:type _NSSize (make-NSSize w h))))))) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 434ef4b8..5495e8b3 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -106,16 +106,15 @@ (define/public (get-selection) (tell #:type _NSInteger content-cocoa selectedRow)) (define/public (get-selections) - (as-entry - (lambda () - (with-autorelease - (let ([v (tell content-cocoa selectedRowIndexes)]) - (begin0 - (let loop ([i (tell #:type _NSInteger v firstIndex)]) - (cond - [(= i NSNotFound) null] - [else (cons i (loop (tell #:type _NSInteger v - indexGreaterThanIndex: #:type _NSInteger i)))])))))))) + (atomically + (with-autorelease + (let ([v (tell content-cocoa selectedRowIndexes)]) + (begin0 + (let loop ([i (tell #:type _NSInteger v firstIndex)]) + (cond + [(= i NSNotFound) null] + [else (cons i (loop (tell #:type _NSInteger v + indexGreaterThanIndex: #:type _NSInteger i)))]))))))) (define/private (visible-range) (tell #:type _NSRange content-cocoa @@ -158,13 +157,12 @@ (define/public (select i [on? #t] [extend? #t]) (if on? - (as-entry - (lambda () - (with-autorelease - (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) - (tellv content-cocoa - selectRowIndexes: index - byExtendingSelection: #:type _BOOL extend?))))) + (atomically + (with-autorelease + (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) + (tellv content-cocoa + selectRowIndexes: index + byExtendingSelection: #:type _BOOL extend?)))) (tellv content-cocoa deselectRow: #:type _NSInteger i))) (define/public (set-selection i) (select i #t #f)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 3d7e2c10..f66c2ddd 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -114,9 +114,9 @@ (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) (define busy-count 0) -(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count))))) +(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count)))) (define (is-busy?) (positive? busy-count)) -(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) +(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count)))) (define (get-display-depth) 32) (define-unimplemented is-color-display?) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index d22745d9..9d2f8813 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -245,7 +245,7 @@ (thread (lambda () (let loop () (sync queue-evt) - (as-entry dispatch-all-ready) + (atomically (dispatch-all-ready)) (loop))))) (set-check-queue! diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 9361147c..79300e50 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -412,28 +412,26 @@ (define depth 0) (define (request-flush-delay cocoa-win) - (as-entry - (lambda () - (let ([req (box cocoa-win)]) - (set! depth (add1 depth)) - (tellv cocoa-win disableFlushWindow) - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (set! depth (sub1 depth)) - (tellv cocoa-win enableFlushWindow) - (tellv cocoa-win flushWindow)))) - req)))) + (atomically + (let ([req (box cocoa-win)]) + (set! depth (add1 depth)) + (tellv cocoa-win disableFlushWindow) + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (tellv cocoa-win flushWindow)))) + req))) (define (cancel-flush-delay req) - (as-entry - (lambda () - (let ([cocoa-win (unbox req)]) - (when cocoa-win - (set-box! req #f) - (set! depth (sub1 depth)) - (tellv cocoa-win enableFlushWindow) - (remove-event-boundary-callback! req)))))) + (atomically + (let ([cocoa-win (unbox req)]) + (when cocoa-win + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (remove-event-boundary-callback! req))))) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 73fdfd5c..7280e68d 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -41,7 +41,7 @@ ;; override this method to set up a callback to ;; `on-backing-flush' when the backing store can be rendered - ;; to the screen + ;; to the screen; called atomically (expecting no exceptions) (define/public (queue-backing-flush) (void)) @@ -102,18 +102,13 @@ (define flush-suspends 0) (define/override (suspend-flush) - (as-entry - (lambda () - ;; if not suspended currently, sleep to encourage any - ;; existing flush requests to complete - (when (zero? flush-suspends) (sleep)) - (set! flush-suspends (add1 flush-suspends))))) + (atomically + (set! flush-suspends (add1 flush-suspends)))) (define/override (resume-flush) - (as-entry - (lambda () - (set! flush-suspends (sub1 flush-suspends)) - (when (zero? flush-suspends) - (queue-backing-flush))))))) + (atomically + (set! flush-suspends (sub1 flush-suspends)) + (when (zero? flush-suspends) + (queue-backing-flush)))))) (define (get-backing-bitmap w h) (make-object bitmap% w h #f #t)) diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt index 79e27f63..2f6301fd 100644 --- a/collects/mred/private/wx/common/timer.rkt +++ b/collects/mred/private/wx/common/timer.rkt @@ -16,10 +16,10 @@ (define current-once? (and just-once? #t)) (define cb #f) (def/public (interval) current-interval) - (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) + (define/private (do-start msec once?) (as-entry (lambda () - (stop) + (do-stop) (set! current-interval msec) (set! current-once? (and once? #t)) (letrec ([new-cb @@ -31,17 +31,19 @@ (lambda () (unless once? (when (eq? cb new-cb) - (start msec #f))))))))]) + (do-start msec #f))))))))]) (set! cb new-cb) (add-timer-callback new-cb))))) - (def/public (stop) + (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) + (do-start msec once?)) + (define/private (do-stop) (as-entry (lambda () (when cb (remove-timer-callback cb) (set! cb #f))))) + (def/public (stop) (do-stop)) (def/public (notify) (notify-cb) (void)) (super-new) (when ival (start ival just-once?))) - diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index cf625f6e..863654ae 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -47,17 +47,16 @@ #:fail (lambda () ;; This by-hand version doesn't produce quite the same notifications. (lambda (gtk value lower upper step-inc page-inc page-size) - (as-entry - (lambda () - (g_object_freeze_notify gtk) - (g_object_set_double gtk "lower" lower) - (g_object_set_double gtk "upper" upper) - (g_object_set_double gtk "step-increment" step-inc) - (g_object_set_double gtk "page-increment" page-inc) - (g_object_set_double gtk "page-size" page-size) - (let ([value (max lower (min value (- upper page-size)))]) - (gtk_adjustment_set_value gtk value)) - (g_object_thaw_notify gtk)))))) + (atomically + (g_object_freeze_notify gtk) + (g_object_set_double gtk "lower" lower) + (g_object_set_double gtk "upper" upper) + (g_object_set_double gtk "step-increment" step-inc) + (g_object_set_double gtk "page-increment" page-inc) + (g_object_set_double gtk "page-size" page-size) + (let ([value (max lower (min value (- upper page-size)))]) + (gtk_adjustment_set_value gtk value)) + (g_object_thaw_notify gtk))))) (define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*)) (define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void)) (define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*) @@ -348,6 +347,7 @@ (queue-paint)) (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) (gtk_widget_queue_draw client-gtk)) (define/override (reset-child-dcs) diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt index d9ff0f56..f8eede10 100644 --- a/collects/mred/private/wx/gtk/check-box.rkt +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -24,11 +24,10 @@ (inherit get-gtk) (define/public (set-value v) - (as-entry - (lambda () - (set! no-clicked? #t) - (gtk_toggle_button_set_active (get-gtk) v) - (set! no-clicked? #f)))) + (atomically + (set! no-clicked? #t) + (gtk_toggle_button_set_active (get-gtk) v) + (set! no-clicked? #f))) (define no-clicked? #f) (define/override (queue-clicked) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 3f1238e8..7c30ae0c 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -71,29 +71,27 @@ (queue-window-event this (lambda () (clicked))))) (define/public (set-selection i) - (as-entry - (lambda () - (set! ignore-clicked? #t) - (gtk_combo_box_set_active gtk i) - (set! ignore-clicked? #f)))) + (atomically + (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) - (as-entry - (lambda () - (set! ignore-clicked? #t) - (for ([i (in-range count)]) - (gtk_combo_box_remove_text gtk 0)) - (set! count 0) - (set! ignore-clicked? #f)))) + (atomically + (set! ignore-clicked? #t) + (for ([i (in-range count)]) + (gtk_combo_box_remove_text gtk 0)) + (set! count 0) + (set! ignore-clicked? #f))) (public [-append append]) (define (-append l) - (as-entry - (lambda () - (set! ignore-clicked? #t) - (set! count (add1 count)) - (gtk_combo_box_append_text gtk l) - (when (= count 1) - (set-selection 0)) - (set! ignore-clicked? #f))))) + (atomically + (set! ignore-clicked? #t) + (set! count (add1 count)) + (gtk_combo_box_append_text gtk l) + (when (= count 1) + (set-selection 0)) + (set! ignore-clicked? #f)))) + diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 3b9f69a2..a4a812dc 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -33,6 +33,7 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) + ;; called atomically (not expecting exceptions) (send canvas queue-backing-flush)))) (define (do-backing-flush canvas dc win) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 7e4f7f28..f2234825 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -160,30 +160,28 @@ (gtk_tree_path_free p))) (define/public (set choices) - (as-entry - (lambda () - (set! ignore-click? #t) - (clear) - (set! items choices) - (set! data (map (lambda (x) (box #f)) choices)) - (reset-content) - (set! ignore-click? #f)))) + (atomically + (set! ignore-click? #t) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content) + (set! ignore-click? #f))) (define/public (get-selections) - (as-entry - (lambda () - (let ([list (gtk_tree_selection_get_selected_rows selection #f)]) - (if list - (let ([v null]) - (g_list_foreach list - (lambda (t) - (set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int) - v))) - #f) - (g_list_foreach list gtk_tree_path_free #f) - (g_list_free list) - (reverse v)) - null))))) + (atomically + (let ([list (gtk_tree_selection_get_selected_rows selection #f)]) + (if list + (let ([v null]) + (g_list_foreach list + (lambda (t) + (set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int) + v))) + #f) + (g_list_foreach list gtk_tree_path_free #f) + (g_list_free list) + (reverse v)) + null)))) (define/public (get-selection) (let ([l (get-selections)]) (if (null? l) @@ -191,14 +189,13 @@ (car l)))) (define/private (get-visible-range) - (as-entry - (lambda () - (let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)]) - (begin0 - (values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0) - (if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0)) - (when sp (gtk_tree_path_free sp)) - (when ep (gtk_tree_path_free ep))))))) + (atomically + (let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)]) + (begin0 + (values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0) + (if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0)) + (when sp (gtk_tree_path_free sp)) + (when ep (gtk_tree_path_free ep)))))) (define/public (get-first-item) (let-values ([(start end) (get-visible-range)]) @@ -219,18 +216,17 @@ (gtk_tree_path_free p)))) (define/public (select i [on? #t] [extend? #t]) - (as-entry - (lambda () - (set! ignore-click? #t) - (let ([p (gtk_tree_path_new_from_indices i -1)]) - (if on? - (begin - (unless extend? - (gtk_tree_selection_unselect_all selection)) - (gtk_tree_selection_select_path selection p)) - (gtk_tree_selection_unselect_path selection p)) - (gtk_tree_path_free p)) - (set! ignore-click? #f)))) + (atomically + (set! ignore-click? #t) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p)) + (set! ignore-click? #f))) (define/public (set-selection i) (select i #t #f)) @@ -248,15 +244,14 @@ (public [append* append]) (define (append* s [v #f]) - (as-entry - (lambda () - (set! ignore-click? #t) - (set! items (append items (list s))) - (set! data (append data (list (box v)))) - (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1)) - (maybe-init-select) - (set! ignore-click? #f)))) + (atomically + (set! ignore-click? #t) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)) + (maybe-init-select) + (set! ignore-click? #f))) - (reset-content)) + (atomically (reset-content))) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index cfcbca4e..1ccf381d 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -39,18 +39,17 @@ (let ([mask (send bm get-loaded-mask)]) (when mask (send mask get-argb-pixels 0 0 w h str #t))) - (as-entry - (lambda () - (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) - (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) - (for ([i (in-range 0 (* w h 4) 4)]) - (bytes-set! rgba (+ i 3) (bytes-ref str i))) - (gdk_pixbuf_new_from_data rgba - 0 - #t - 8 - w - h - (* w 4) - free-it - #f)))))) + (atomically + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) + (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) + (for ([i (in-range 0 (* w h 4) 4)]) + (bytes-set! rgba (+ i 3) (bytes-ref str i))) + (gdk_pixbuf_new_from_data rgba + 0 + #t + 8 + w + h + (* w 4) + free-it + #f))))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 8753291b..32639281 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -120,9 +120,9 @@ (define (hide-cursor) (void)) (define busy-count 0) -(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count))))) +(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count)))) (define (is-busy?) (positive? busy-count)) -(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) +(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count)))) (define-unimplemented is-color-display?) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 7f633906..bc6d8c35 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -3,7 +3,7 @@ ffi/unsafe "utils.rkt" "types.rkt" - racket/draw/lock + "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" "const.rkt") @@ -131,5 +131,5 @@ (thread (lambda () (let loop () (sync queue-evt) - (as-entry dispatch-all-ready) + (atomically (dispatch-all-ready)) (loop))))) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index e1c20879..2f19912f 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -102,17 +102,16 @@ (define/override (set-focus) (button-focus (max 0 (set-selection)))) (define/public (set-selection i) - (as-entry - (lambda () - (set! no-clicked? #t) - (if (= i -1) - (when (pair? radio-gtks) - (unless dummy-gtk - (set! dummy-gtk (gtk_radio_button_new - (gtk_radio_button_get_group (car radio-gtks))))) - (gtk_toggle_button_set_active dummy-gtk #t)) - (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) - (set! no-clicked? #f)))) + (atomically + (set! no-clicked? #t) + (if (= i -1) + (when (pair? radio-gtks) + (unless dummy-gtk + (set! dummy-gtk (gtk_radio_button_new + (gtk_radio_button_get_group (car radio-gtks))))) + (gtk_toggle_button_set_active dummy-gtk #t)) + (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) + (set! no-clicked? #f))) (define/public (get-selection) (or (for/or ([radio-gtk (in-list radio-gtks)] diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index d2280ef3..48a0098d 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -68,10 +68,9 @@ [time-stamp (current-milliseconds)])))))) (define/public (set-value v) - (as-entry - (lambda () - (set! ignore-click? #t) - (gtk_range_set_value gtk v) - (set! ignore-click? #f)))) + (atomically + (set! ignore-click? #t) + (gtk_range_set_value gtk v) + (set! ignore-click? #f))) (define/public (get-value) (inexact->exact (floor (gtk_range_get_value gtk))))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index a85982a0..34ab5f9f 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -380,13 +380,12 @@ (define shown? #f) (define/public (direct-show on?) - (as-entry - (lambda () - (if on? - (gtk_widget_show gtk) - (gtk_widget_hide gtk)) - (set! shown? (and on? #t)) - (register-child-in-parent on?))) + (atomically + (if on? + (gtk_widget_show gtk) + (gtk_widget_hide gtk)) + (set! shown? (and on? #t)) + (register-child-in-parent on?)) (when on? (reset-child-dcs))) (define/public (show on?) (direct-show on?)) From 2197b56aab5562febbb7feb8fbccc12cc0b5511a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Aug 2010 20:33:30 -0600 Subject: [PATCH 156/462] clean up cocoa memory management and also fix vertical sliders and guages original commit: 152a8b67039ba64e8945ffa513c91f2dafa8e99d --- collects/mred/private/wx/cocoa/button.rkt | 11 +++++----- collects/mred/private/wx/cocoa/frame.rkt | 16 +++++++------- collects/mred/private/wx/cocoa/gauge.rkt | 21 ++++++++++++------ collects/mred/private/wx/cocoa/list-box.rkt | 10 +++++---- collects/mred/private/wx/cocoa/menu-item.rkt | 11 +++++----- collects/mred/private/wx/cocoa/pool.rkt | 3 +++ collects/mred/private/wx/cocoa/queue.rkt | 6 +++-- collects/mred/private/wx/cocoa/slider.rkt | 5 +++-- collects/mred/private/wx/cocoa/types.rkt | 6 +++-- collects/mred/private/wx/cocoa/utils.rkt | 9 ++++---- collects/mred/private/wxlitem.rkt | 23 ++++++++++++-------- 11 files changed, 73 insertions(+), 48 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 466382e8..dbff38f0 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -79,11 +79,12 @@ (send label get-width))] [new-height (max (NSSize-height (NSRect-size frame)) (send label get-height))]) - (let ([cocoa (tell (tell NSView alloc) - initWithFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize new-width - new-height)))] + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] [image-cocoa (as-objc-allocation (tell (tell NSImageView alloc) init))]) (tellv cocoa addSubview: button-cocoa) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 39b18c8d..39510db6 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -229,14 +229,14 @@ endSheet: cocoa)))) (tellv cocoa orderOut: #f) (let ([next - (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] - [wins (tell (tell NSApplication sharedApplication) orderedWindows)]) - (begin0 - (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) - (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) - (and (tell #:type _BOOL win isVisible) - win))) - (tellv pool release)))]) + (atomically + (with-autorelease + (let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)]) + (begin0 + (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) + (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) + (and (tell #:type _BOOL win isVisible) + win)))))))]) (cond [next (tellv next makeKeyWindow)] [root-fake-frame (send root-fake-frame install-mb)] diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index 32241caa..04be1294 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class scheme/foreign + racket/math ffi/objc "../../syntax.rkt" "item.rkt" @@ -18,7 +19,7 @@ (import-class NSProgressIndicator) (define-objc-class MyProgressIndicator NSProgressIndicator - #:mixins () + #:mixins (KeyMouseResponder) [wxb]) (defclass gauge% item% @@ -31,16 +32,22 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (tell (tell MyProgressIndicator alloc) init)]) + [cocoa (let ([cocoa (as-objc-allocation + (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) (tellv cocoa setDoubleValue: #:type _double* 0.0) - #; - (tellv cocoa setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (if vert? 24 32) - (if vert? 32 24)))) (tellv cocoa sizeToFit) + (when (memq 'vertical style) + (let ([r (tell #:type _NSRect cocoa frame)]) + (printf "height ~s\n" (NSSize-height (NSRect-size r))) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect + (NSRect-origin r) + (make-NSSize + (NSSize-height (NSRect-size r)) + (NSSize-width (NSRect-size r))))) + (tellv cocoa rotateByAngle: #:type _CGFloat -90))) cocoa)] [callback void] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 5495e8b3..6b86fd00 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -26,8 +26,10 @@ [wxb] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (let ([wx (->wx wxb)]) - (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-row row) "???")))] + (tell + (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???")) + autorelease))] [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] [-a _void (tableViewSelectionDidChange: [_id aNotification]) @@ -70,8 +72,8 @@ (define cocoa (as-objc-allocation (tell (tell NSScrollView alloc) init))) (define content-cocoa (let ([content-cocoa - (as-objc-allocation - (tell (tell MyTableView alloc) init))]) + (as-objc-allocation + (tell (tell MyTableView alloc) init))]) (tellv content-cocoa setDelegate: content-cocoa) (tellv content-cocoa setDataSource: source) (tellv content-cocoa addTableColumn: diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 2e532ebb..2356214c 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -50,10 +50,11 @@ (define/public (install menu) (if submenu (send submenu install menu label) - (let ([item (tell (tell MyMenuItem alloc) - initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") - action: #:type _SEL #f - keyEquivalent: #:type _NSString "")]) + (let ([item (as-objc-allocation + (tell (tell MyMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString ""))]) (set-ivar! item wxb (->wxb this)) (tellv menu addItem: item) (tellv item setEnabled: #:type _BOOL enabled?) @@ -78,6 +79,6 @@ NSCommandKeyMask))]) (tellv item setKeyEquivalent: #:type _NSString s) (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) - (tellv item release)))) + (release item)))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt index 4f021023..aff29ab9 100644 --- a/collects/mred/private/wx/cocoa/pool.rkt +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -11,4 +11,7 @@ (import-class NSAutoreleasePool) +;; This pool manages all objects that would otherwise not +;; have a pool, which makes them stick around until the +;; process exits. (define pool (tell (tell NSAutoreleasePool alloc) init)) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9d2f8813..abef5c0c 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -230,8 +230,10 @@ (queue-event e (lambda () (call-as-nonatomic-retry-point (lambda () - (tellv app sendEvent: evt) - (release evt)))))) + ;; in atomic mode + (with-autorelease + (tellv app sendEvent: evt) + (release evt))))))) (tellv app sendEvent: evt))) #t))) (tellv pool release)))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 92dd980a..19f086bb 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -43,7 +43,8 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (tell (tell MySlider alloc) init)] + [cocoa (let ([cocoa (as-objc-allocation + (tell (tell MySlider alloc) init))] [vert? (memq 'vertical style)]) (tellv cocoa setMinValue: #:type _double* lo) (tellv cocoa setMaxValue: #:type _double* hi) @@ -53,7 +54,7 @@ (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize (if vert? 24 32) - (if vert? 32 24)))) + (if vert? 64 24)))) (tellv cocoa setContinuous: #:type _BOOL #t) ; (tellv cocoa sizeToFit) cocoa)] diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index fed4632b..accaffc8 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/objc scheme/foreign + "../../lock.rkt" "utils.rkt") (unsafe!) (objc-unsafe!) @@ -51,9 +52,10 @@ (hash-set! strings v s) s))) (lambda (v) - (with-autorelease + (atomically + (with-autorelease (let ([s (tell #:type _bytes v UTF8String)]) - (bytes->string/utf-8 s)))))) + (bytes->string/utf-8 s))))))) (define NSNotFound (if 64-bit? #x7fffffffffffffff diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 72167b6c..a4486769 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -41,11 +41,12 @@ (import-class NSAutoreleasePool) -(define-syntax-rule (with-autorelease expr) - (call-with-autorelease (lambda () expr))) +;; Use `with-autorelease' and `call-with-autorelease' +;; in atomic mode +(define-syntax-rule (with-autorelease expr ...) + (call-with-autorelease (lambda () expr ...))) (define (call-with-autorelease thunk) - (let ([pool (as-objc-allocation - (tell (tell NSAutoreleasePool alloc) init))]) + (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (begin0 (thunk) (release pool)))) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 597b3a62..5b507d9e 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -67,17 +67,17 @@ (unless (memq 'deleted style) (send (area-parent) add-child this)) (define horiz? (is-horiz? style parent)) - (define p (make-sub horiz? proxy this 'left valign)) + (define p (make-sub horiz? proxy this (if horiz? 'left 'center) valign)) (define l (make-label label proxy p font)) (define/public (set-label s) (when l (send l set-label s))) (define/public (get-label) (and l (send l get-label))) (define/public (get-p) p) - (define/public (set-c v) + (define/public (set-c v sx? sy?) (set! c v) - (send c stretchable-in-x #t) - (send c stretchable-in-y #t) + (send c stretchable-in-x sx?) + (send c stretchable-in-y sy?) (send c skip-subwindow-events? #t)))) ;; ---------------------------------------- @@ -100,7 +100,7 @@ (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices (filter-style style) font)) - (set-c c) + (set-c c #t #f) (bounce c @@ -158,7 +158,7 @@ (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices (filter-style style) font label-font)) - (set-c c) + (set-c c #t #t) (bounce c @@ -231,7 +231,7 @@ (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices major (filter-style style) font)) - (set-c c) + (set-c c #t #t) (define/override enable (case-lambda @@ -306,7 +306,9 @@ (define c (make-object wx-internal-gauge% mred proxy (get-p) label range (filter-style style) font)) - (set-c c) + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) (bounce c @@ -362,7 +364,10 @@ (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val (filter-style style) font)) - (set-c c) + + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) (bounce c From 1752204327248d43f64a62d6bcb0d9e7f661df28 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 15 Aug 2010 10:56:02 -0600 Subject: [PATCH 157/462] more memory management original commit: c7049058336382b651c82b3a98c8a7feb9311257 --- collects/mred/private/wx/cocoa/image.rkt | 7 ++-- collects/mred/private/wx/cocoa/pool.rkt | 43 ++++++++++++++++++---- collects/mred/private/wx/cocoa/queue.rkt | 2 + collects/mred/private/wx/cocoa/window.rkt | 20 ++++++++-- collects/mred/private/wx/common/queue.rkt | 14 +++++-- collects/mred/private/wx/gtk/button.rkt | 32 +++++++++------- collects/mred/private/wx/gtk/frame.rkt | 17 ++++++--- collects/mred/private/wx/gtk/message.rkt | 18 +++++---- collects/mred/private/wx/gtk/pixbuf.rkt | 10 ++++- collects/mred/private/wx/gtk/radio-box.rkt | 13 ++++--- collects/mred/private/wx/gtk/utils.rkt | 21 ++++++++++- 11 files changed, 145 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index f95cf7d1..07f2d1d8 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -79,6 +79,7 @@ 0)]) (CGDataProviderRelease provider) (CGColorSpaceRelease cs) - (tell (tell NSImage alloc) - initWithCGImage: #:type _CGImageRef image - size: #:type _NSSize (make-NSSize w h))))))) + (as-objc-allocation + (tell (tell NSImage alloc) + initWithCGImage: #:type _CGImageRef image + size: #:type _NSSize (make-NSSize w h)))))))) diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt index aff29ab9..5a101fc4 100644 --- a/collects/mred/private/wx/cocoa/pool.rkt +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -1,17 +1,44 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + ffi/unsafe/atomic "utils.rkt" "const.rkt" "types.rkt") -(unsafe!) -(objc-unsafe!) -(provide pool) +(provide queue-autorelease-flush + autorelease-flush) (import-class NSAutoreleasePool) ;; This pool manages all objects that would otherwise not -;; have a pool, which makes them stick around until the -;; process exits. +;; have a pool: (define pool (tell (tell NSAutoreleasePool alloc) init)) + +;; We need to periodically flush the main pool, otherwise +;; object autoreleased through the pool live until the +;; end of execution: +(define (autorelease-flush) + (start-atomic) + (tellv pool drain) + (set! pool (tell (tell NSAutoreleasePool alloc) init)) + (end-atomic)) + +(define queued? #f) +(define autorelease-evt (make-semaphore)) + +(define (queue-autorelease-flush) + (start-atomic) + (unless queued? + (semaphore-post autorelease-evt) + (set! queued? #t)) + (end-atomic)) + +;; Create a thread to periodically flush: +(void + (thread (lambda () + (let loop () + (sync autorelease-evt) + (set! queued? #f) + (autorelease-flush) + (loop))))) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index abef5c0c..357c8a7d 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -79,6 +79,7 @@ subtype: #:type _short 0 data1: #:type _NSInteger 0 data2: #:type _NSInteger 0)) +(retain wake-evt) (define (post-dummy-event) (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES)) @@ -248,6 +249,7 @@ (let loop () (sync queue-evt) (atomically (dispatch-all-ready)) + (queue-autorelease-flush) (loop))))) (set-check-queue! diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 79300e50..cc2df439 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -7,6 +7,7 @@ "const.rkt" "types.rkt" "keycode.rkt" + "pool.rkt" "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" @@ -128,6 +129,12 @@ [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () @@ -175,6 +182,8 @@ (super-new) + (queue-autorelease-flush) + (define eventspace (if parent (send parent get-eventspace) (current-eventspace))) @@ -211,10 +220,15 @@ (define/public (get-eventspace) eventspace) + (define is-on? #f) (define/public (show on?) - (if on? - (tellv (send parent get-cocoa-content) addSubview: cocoa) - (tellv cocoa removeFromSuperview)) + (atomically + (unless (eq? (and on? #t) is-on?) + (if on? + (tellv (send parent get-cocoa-content) addSubview: cocoa) + (with-autorelease + (tellv cocoa removeFromSuperview))) + (set! is-on? (and on? #t)))) (maybe-register-as-child parent on?)) (define/public (maybe-register-as-child parent on?) (void)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 3f22945e..bf93f755 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -302,9 +302,17 @@ ((eventspace-queue-proc eventspace) (cons level thunk))) (define (handle-event thunk) - (call-with-continuation-barrier - (lambda () - (call-with-continuation-prompt thunk)))) + (let/ec esc + (let ([done? #f]) + (dynamic-wind + void + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt thunk))) + (set! done? #t)) + (lambda () + (unless done? (esc (void)))))))) (define yield (case-lambda diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 41a0388d..3c207178 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -2,6 +2,7 @@ (require scheme/foreign scheme/class "../../syntax.rkt" + "../../lock.rkt" "item.rkt" "utils.rkt" "types.rkt" @@ -43,16 +44,19 @@ (super-new [parent parent] [gtk (cond [(or (string? label) (not label)) - (gtk_new_with_mnemonic (or (mnemonic-string label) ""))] + (as-gtk-allocation + (gtk_new_with_mnemonic (or (mnemonic-string label) "")))] [(send label ok?) - (let ([gtk (gtk_new)] - [image-gtk (gtk_image_new_from_pixbuf - (bitmap->pixbuf label))]) - (gtk_container_add gtk image-gtk) - (gtk_widget_show image-gtk) - gtk)] + (let ([pixbuf (bitmap->pixbuf label)]) + (atomically + (let ([gtk (as-gtk-allocation (gtk_new))] + [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk) + gtk)))] [else - (gtk_new_with_mnemonic "")])] + (as-gtk-allocation (gtk_new_with_mnemonic ""))])] [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) @@ -82,11 +86,13 @@ [(string? s) (gtk_button_set_label gtk (mnemonic-string s))] [else - (let ([image-gtk (gtk_image_new_from_pixbuf - (bitmap->pixbuf s))]) - (gtk_container_remove gtk (gtk_bin_get_child gtk)) - (gtk_container_add gtk image-gtk) - (gtk_widget_show image-gtk))])) + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_remove gtk (gtk_bin_get_child gtk)) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk))))])) (define/public (set-border on?) (gtk_window_set_default (get-window-gtk) (if on? gtk #f)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 3ba10a7c..df5eda5e 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -2,6 +2,7 @@ (require scheme/foreign scheme/class "../../syntax.rkt" + "../../lock.rkt" "utils.rkt" "const.rkt" "types.rkt" @@ -103,13 +104,17 @@ get-parent get-eventspace adjust-client-delta) - (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL)) + (define gtk (as-gtk-window-allocation + (gtk_window_new GTK_WINDOW_TOPLEVEL))) (when (memq 'no-caption style) - (gtk_window_set_decorated gtk #f)) - (define vbox-gtk (gtk_vbox_new #f 0)) - (define panel-gtk (gtk_fixed_new)) - (gtk_container_add gtk vbox-gtk) - (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0) + (gtk_window_set_decorated gtk #f)) + (define-values (vbox-gtk panel-gtk) + (atomically + (let ([vbox-gtk (gtk_vbox_new #f 0)] + [panel-gtk (gtk_fixed_new)]) + (gtk_container_add gtk vbox-gtk) + (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0) + (values vbox-gtk panel-gtk)))) (gtk_widget_show vbox-gtk) (gtk_widget_show panel-gtk) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 91678fb0..5f2552a5 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -51,15 +51,19 @@ (super-new [parent parent] [gtk (if (or (string? label) (not label)) - (gtk_label_new_with_mnemonic (or label "")) + (as-gtk-allocation (gtk_label_new_with_mnemonic (or label ""))) (if (symbol? label) - (case label - [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] - [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] - [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]) + (as-gtk-allocation + (case label + [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] + [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] + [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])) (if (send label ok?) - (gtk_image_new_from_pixbuf - (bitmap->pixbuf label)) + (let ([pixbuf (bitmap->pixbuf label)]) + (begin0 + (as-gtk-allocation + (gtk_image_new_from_pixbuf pixbuf)) + (release-pixbuf pixbuf))) (gtk_label_new_with_mnemonic ""))))] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index 1ccf381d..d6112203 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -1,6 +1,7 @@ #lang racket (require racket/class ffi/unsafe + ffi/unsafe/alloc racket/draw "../../lock.rkt" "../common/bstr.rkt" @@ -10,10 +11,13 @@ (provide _GdkPixbuf bitmap->pixbuf - gtk_image_new_from_pixbuf) + gtk_image_new_from_pixbuf + release-pixbuf) (define _GdkPixbuf (_cpointer 'GdkPixbuf)) +(define release-pixbuf ((deallocator) g_object_unref)) + (define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget)) (define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data _int ; 0 =RGB @@ -24,7 +28,9 @@ _int ; rowstride _fpointer ; destroy _pointer ; destroy data - -> _GdkPixbuf)) + -> _GdkPixbuf) + #:wrap (allocator release-pixbuf)) + (define free-it (ffi-callback free (list _pointer) _void diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 2f19912f..011e5426 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -52,12 +52,13 @@ [(string? lbl) (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] [(send lbl ok?) - (let ([radio-gtk (gtk_radio_button_new #f)] - [image-gtk (gtk_image_new_from_pixbuf - (bitmap->pixbuf lbl))]) - (gtk_container_add radio-gtk image-gtk) - (gtk_widget_show image-gtk) - radio-gtk)] + (let ([pixbuf (bitmap->pixbuf lbl)]) + (let ([radio-gtk (gtk_radio_button_new #f)] + [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_add radio-gtk image-gtk) + (gtk_widget_show image-gtk) + radio-gtk))] [else (gtk_radio_button_new_with_mnemonic #f "")])]) (gtk_box_pack_start gtk radio-gtk #t #t 0) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 43435a2d..c157df50 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/unsafe ffi/unsafe/define + ffi/unsafe/alloc (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") @@ -16,6 +17,9 @@ g_object_ref g_object_unref + as-gtk-allocation + as-gtk-window-allocation + g_free _gpath/free _GSList @@ -82,8 +86,23 @@ (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) -(define-gobj g_object_ref (_fun _pointer -> _void)) +(define-gobj g_object_ref (_fun _pointer -> _pointer)) (define-gobj g_object_unref (_fun _pointer -> _void)) +(define-gobj g_object_ref_sink (_fun _pointer -> _pointer)) + +(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) + +(define gtk-destroy ((deallocator) (lambda (v) + (gtk_widget_destroy v) + (g_object_unref v)))) +(define gtk-allocator (allocator gtk-destroy)) + +(define-syntax-rule (as-gtk-allocation expr) + ((gtk-allocator (lambda () (let ([v expr]) + (g_object_ref_sink v) + v))))) +(define-syntax-rule (as-gtk-window-allocation expr) + ((gtk-allocator (lambda () expr)))) (define-glib g_free (_fun _pointer -> _void)) From a4305ae6a2ebf8167b52a28e6bb8e3f40a817f98 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 08:31:32 -0600 Subject: [PATCH 158/462] finish pinning down gtk allocation original commit: 43aeaacd7a598f834002b75b1ee72f4b7cd04b85 --- collects/mred/private/wx/cocoa/README.txt | 15 +++ collects/mred/private/wx/gtk/README.txt | 17 +++ collects/mred/private/wx/gtk/canvas.rkt | 122 ++++++++++--------- collects/mred/private/wx/gtk/choice.rkt | 2 +- collects/mred/private/wx/gtk/gauge.rkt | 8 +- collects/mred/private/wx/gtk/group-panel.rkt | 9 +- collects/mred/private/wx/gtk/list-box.rkt | 57 +++++---- collects/mred/private/wx/gtk/menu-bar.rkt | 41 ++++--- collects/mred/private/wx/gtk/menu.rkt | 57 +++++---- collects/mred/private/wx/gtk/panel.rkt | 2 +- collects/mred/private/wx/gtk/radio-box.rkt | 45 +++---- collects/mred/private/wx/gtk/slider.rkt | 7 +- collects/mred/private/wx/gtk/utils.rkt | 12 ++ collects/mred/private/wx/gtk/widget.rkt | 24 ++-- 14 files changed, 246 insertions(+), 172 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/README.txt create mode 100644 collects/mred/private/wx/gtk/README.txt diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt new file mode 100644 index 00000000..df44db48 --- /dev/null +++ b/collects/mred/private/wx/cocoa/README.txt @@ -0,0 +1,15 @@ + +Allocation rules: + + * Use `as-objc-allocation' when creating a Cocoa object. When the + resulting reference becomes unreachable, the Cocoa object will be + releaset. + + * Use `with-autorelease' in atomic mode around calls that autorelease + and where the release should take effect immediate. Do not create + an autorelease pool except in atomic mode. + + * Other autoreleased objects may end up in the root pool installed by + "pool.rkt". The root pool is periodically destroyed and replaced; + call `queue-autorelease-flush' if you need to encurage replacement + of the pool. diff --git a/collects/mred/private/wx/gtk/README.txt b/collects/mred/private/wx/gtk/README.txt new file mode 100644 index 00000000..2f55c326 --- /dev/null +++ b/collects/mred/private/wx/gtk/README.txt @@ -0,0 +1,17 @@ + +Allocation rules: + + * Use `as-gtk-allocation' when creating a Gtk widget that is the main + container for a given window<%> object. When the resulting + reference becomes unreachable, the widget will be released with + gtk_widget_destroy() through a finalizer. + + * Use `atomically' to create and attach a sub-widget within the main + widget. Don't use gtk_widget_destroy(); the containing widget will + destroy the enclosing widget. + + * For temporary objects, use `atomically' to wrap both the allocation + and release. + +Every call to a function whose name contains "new" needs to be in one +of those cases. diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 863654ae..8d71ad50 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -135,7 +135,8 @@ (let ([gc (send wx get-canvas-background-for-clearing)]) (when gc (gdk_draw_rectangle (widget-window gtk) gc #t - 0 0 32000 32000)))))) + 0 0 32000 32000) + (gdk_gc_unref gc)))))) #t)) (define-signal-handler connect-expose-border "expose-event" @@ -197,61 +198,62 @@ (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box combo-button-gtk) - (cond - [(or (memq 'hscroll style) - (memq 'vscroll style)) - (let* ([client-gtk (gtk_drawing_area_new)] - [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] - [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) - (let ([h (gtk_hbox_new #f 0)] - [v (gtk_vbox_new #f 0)] - [v2 (gtk_vbox_new #f 0)] - [h2 (gtk_vbox_new #f 0)] - [hscroll (gtk_hscrollbar_new hadj)] - [vscroll (gtk_vscrollbar_new vadj)] - [resize-box (gtk_drawing_area_new)]) - (when has-border? - (gtk_container_set_border_width h margin)) - (gtk_box_pack_start h v #t #t 0) - (gtk_box_pack_start v client-gtk #t #t 0) - (gtk_box_pack_start h v2 #f #f 0) - (gtk_box_pack_start v2 vscroll #t #t 0) - (gtk_box_pack_start v h2 #f #f 0) - (gtk_box_pack_start h2 hscroll #t #t 0) - (gtk_box_pack_start v2 resize-box #f #f 0) - (gtk_widget_show hscroll) - (gtk_widget_show vscroll) - (gtk_widget_show h) - (gtk_widget_show v) - (gtk_widget_show v2) - (gtk_widget_show h2) - (gtk_widget_show resize-box) - (gtk_widget_show client-gtk) - (unless (memq 'hscroll style) - (gtk_widget_hide hscroll) - (gtk_widget_hide resize-box)) - (unless (memq 'vscroll style) - (gtk_widget_hide v2)) - (values client-gtk h hadj vadj - (and (memq 'hscroll style) h2) - (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box) - #f)))] - [is-combo? - (let* ([gtk (gtk_combo_box_entry_new_text)] - [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] - [has-border? - (let ([client-gtk (gtk_drawing_area_new)] - [h (gtk_hbox_new #f 0)]) - (gtk_box_pack_start h client-gtk #t #t 0) - (gtk_container_set_border_width h margin) - (connect-expose-border h) - (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f #f))] - [else - (let ([client-gtk (gtk_drawing_area_new)]) - (values client-gtk client-gtk #f #f #f #f #f #f))])) + (atomically ;; need to connect all children to gtk to avoid leaks + (cond + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + (when has-border? + (gtk_container_set_border_width h margin)) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (gtk_widget_show hscroll) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (gtk_widget_show v2) + (gtk_widget_show h2) + (gtk_widget_show resize-box) + (gtk_widget_show client-gtk) + (unless (memq 'hscroll style) + (gtk_widget_hide hscroll) + (gtk_widget_hide resize-box)) + (unless (memq 'vscroll style) + (gtk_widget_hide v2)) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f)))] + [is-combo? + (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] + [orig-entry (gtk_bin_get_child gtk)]) + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (as-gtk-allocation (gtk_hbox_new #f 0))]) + (gtk_box_pack_start h client-gtk #t #t 0) + (gtk_container_set_border_width h margin) + (connect-expose-border h) + (gtk_widget_show client-gtk) + (values client-gtk h #f #f #f #f #f #f))] + [else + (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) + (values client-gtk client-gtk #f #f #f #f #f #f))]))) (super-new [parent parent] [gtk gtk] @@ -481,15 +483,15 @@ bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) + ;; called in event-dispatch mode (if now-drawing? (begin (set! refresh-after-drawing? #t) #f) (if clear-bg? - (let ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]) - (unless gc - (let ([w (widget-window gtk)]) - (set! gc (gdk_gc_new w)))) + (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] + [w (widget-window gtk)] + [gc (gdk_gc_new w)]) (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 (conv (color-red bg-col)) (conv (color-green bg-col)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 7c30ae0c..0f79c489 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -35,7 +35,7 @@ choices style font) (inherit get-gtk set-auto-size) - (define gtk (gtk_combo_box_new_text)) + (define gtk (as-gtk-allocation (gtk_combo_box_new_text))) (define count (length choices)) (for ([l (in-list choices)]) diff --git a/collects/mred/private/wx/gtk/gauge.rkt b/collects/mred/private/wx/gtk/gauge.rkt index 6670f323..2bb45011 100644 --- a/collects/mred/private/wx/gtk/gauge.rkt +++ b/collects/mred/private/wx/gtk/gauge.rkt @@ -15,6 +15,9 @@ (define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void)) +(define-gtk gtk_progress_bar_set_orientation (_fun _GtkWidget _int -> _void)) + +(define GTK_PROGRESS_BOTTOM_TO_TOP 2) (defclass gauge% item% (init parent @@ -26,10 +29,13 @@ (inherit get-gtk set-auto-size) (super-new [parent parent] - [gtk (gtk_progress_bar_new #f)] + [gtk (as-gtk-allocation (gtk_progress_bar_new #f))] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) + (when (memq 'vertical style) + (gtk_progress_bar_set_orientation gtk GTK_PROGRESS_BOTTOM_TO_TOP)) + (set-auto-size) (define range rng) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index a147a034..4c718d49 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -2,6 +2,7 @@ (require scheme/class scheme/foreign "../../syntax.rkt" + "../../lock.rkt" "window.rkt" "client-window.rkt" "panel.rkt" @@ -29,9 +30,11 @@ (inherit set-size set-auto-size infer-client-delta get-gtk get-height) - (define gtk (gtk_frame_new label)) - (define client-gtk (gtk_fixed_new)) - (gtk_container_add gtk client-gtk) + (define gtk (as-gtk-allocation (gtk_frame_new label))) + (define client-gtk + (atomically (let ([client-gtk (gtk_fixed_new)]) + (gtk_container_add gtk client-gtk) + client-gtk))) (gtk_widget_show client-gtk) (super-new [parent parent] diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index f2234825..1fdb8638 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -75,7 +75,7 @@ (define items choices) (define data (map (lambda (c) (box #f)) choices)) - (define store (gtk_list_store_new 1 G_TYPE_STRING)) + (define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING))) (define (reset-content) (let ([iter (make-GtkTreeIter 0 #f #f #f)]) (for ([s (in-list items)]) @@ -88,23 +88,23 @@ (pair? data)) (set-selection 0))) - (define column - (let ([renderer (gtk_cell_renderer_text_new)]) - (gtk_tree_view_column_new_with_attributes - "column" - renderer - "text" - 0 - #f))) - - (define gtk (gtk_scrolled_window_new #f #f)) + (define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f))) (gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS) (define client-gtk - (let* ([client-gtk (gtk_tree_view_new_with_model store)]) - (gtk_tree_view_set_headers_visible client-gtk #f) - (gtk_tree_view_append_column client-gtk column) - client-gtk)) + (atomically + (let* ([client-gtk (gtk_tree_view_new_with_model store)] + [column (let ([renderer (gtk_cell_renderer_text_new)]) + (gtk_tree_view_column_new_with_attributes + "column" + renderer + "text" + 0 + #f))]) + (gobject-unref store) + (gtk_tree_view_set_headers_visible client-gtk #f) + (gtk_tree_view_append_column client-gtk column) + client-gtk))) (gtk_container_add gtk client-gtk) (gtk_widget_show client-gtk) @@ -139,11 +139,12 @@ [time-stamp (current-milliseconds)]))))))) (define/private (get-iter i) - (let ([iter (make-GtkTreeIter 0 #f #f #f)] - [p (gtk_tree_path_new_from_indices i -1)]) - (gtk_tree_model_get_iter store iter p) - (gtk_tree_path_free p) - iter)) + (atomically + (let ([iter (make-GtkTreeIter 0 #f #f #f)] + [p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_model_get_iter store iter p) + (gtk_tree_path_free p) + iter))) (def/public-unimplemented get-label-font) @@ -155,9 +156,10 @@ (gtk_list_store_set store (get-iter i) 0 s -1)) (define/public (set-first-visible-item i) - (let ([p (gtk_tree_path_new_from_indices i -1)]) - (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) - (gtk_tree_path_free p))) + (atomically + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) + (gtk_tree_path_free p)))) (define/public (set choices) (atomically @@ -210,10 +212,11 @@ (define/public (get-data i) (unbox (list-ref data i))) (define/public (selected? i) - (let ([p (gtk_tree_path_new_from_indices i -1)]) - (begin0 - (gtk_tree_selection_path_is_selected selection p) - (gtk_tree_path_free p)))) + (atomically + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (begin0 + (gtk_tree_selection_path_is_selected selection p) + (gtk_tree_path_free p))))) (define/public (select i [on? #t] [extend? #t]) (atomically diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index a51a944a..8a752538 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -2,6 +2,7 @@ (require scheme/class scheme/foreign "../../syntax.rkt" + "../../lock.rkt" "../common/freeze.rkt" "../common/queue.rkt" "widget.rkt" @@ -73,7 +74,7 @@ (define menus null) - (define gtk (gtk_menu_bar_new)) + (define gtk (as-gtk-allocation (gtk_menu_bar_new))) (super-new [gtk gtk]) (define/public (get-gtk) gtk) @@ -88,15 +89,16 @@ (install-widget-parent top) ;; return initial size; also, add a menu to make sure there is one, ;; and force the menu bar to be at least that tall always - (let ([item (gtk_menu_item_new_with_mnemonic "Xyz")]) - (gtk_menu_shell_append gtk item) - (gtk_widget_show item) - (begin0 - (let ([req (make-GtkRequisition 0 0)]) - (gtk_widget_size_request gtk req) - (gtk_widget_set_usize gtk -1 (GtkRequisition-height req)) - (GtkRequisition-height req)) - (gtk_container_remove gtk item)))) + (atomically + (let ([item (gtk_menu_item_new_with_mnemonic "Xyz")]) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item) + (begin0 + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (gtk_widget_set_usize gtk -1 (GtkRequisition-height req)) + (GtkRequisition-height req)) + (gtk_container_remove gtk item))))) (define/public (get-top-window) top-wx) @@ -129,12 +131,13 @@ (public [append-menu append]) (define (append-menu menu title) (send menu set-parent this) - (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] - [item-wx (new top-menu% [parent this] [gtk item])]) - (connect-select item) - (set! menus (append menus (list (list item menu item-wx)))) - (let ([gtk (send menu get-gtk)]) - (g_object_ref gtk) - (gtk_menu_item_set_submenu item gtk)) - (gtk_menu_shell_append gtk item) - (gtk_widget_show item)))) + (atomically + (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] + [item-wx (new top-menu% [parent this] [gtk item])]) + (connect-select item) + (set! menus (append menus (list (list item menu item-wx)))) + (let ([gtk (send menu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item gtk)) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item))))) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 0698d6a4..4d145ec9 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -4,6 +4,7 @@ "widget.rkt" "window.rkt" "../../syntax.rkt" + "../../lock.rkt" "types.rkt" "const.rkt" "utils.rkt" @@ -80,7 +81,7 @@ (define cb callback) - (define gtk (gtk_menu_new)) + (define gtk (as-gtk-allocation (gtk_menu_new))) (define/public (get-gtk) gtk) (super-new [gtk gtk]) @@ -175,34 +176,36 @@ (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) - (let ([item-gtk ((if chckable? - gtk_check_menu_item_new_with_mnemonic - gtk_menu_item_new_with_mnemonic) - (fixup-mneumonic label))]) - (if (help-str-or-submenu . is-a? . menu%) - (let ([submenu help-str-or-submenu]) - (let ([gtk (send submenu get-gtk)]) - (g_object_ref gtk) - (gtk_menu_item_set_submenu item-gtk gtk) - (send submenu set-parent this) - (send submenu set-self-item i - (lambda () (gtk_menu_item_set_submenu item-gtk #f))) - (set! items (append items (list (list submenu item-gtk label chckable?)))))) - (let ([item (new menu-item-handler% - [gtk item-gtk] - [menu this] - [menu-item i] - [parent this])]) - (set! items (append items (list (list item item-gtk label chckable?)))) - (adjust-shortcut item-gtk label))) - (gtk_menu_shell_append gtk item-gtk) - (gtk_widget_show item-gtk))) + (atomically + (let ([item-gtk ((if chckable? + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + (fixup-mneumonic label))]) + (if (help-str-or-submenu . is-a? . menu%) + (let ([submenu help-str-or-submenu]) + (let ([gtk (send submenu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item-gtk gtk) + (send submenu set-parent this) + (send submenu set-self-item i + (lambda () (gtk_menu_item_set_submenu item-gtk #f))) + (set! items (append items (list (list submenu item-gtk label chckable?)))))) + (let ([item (new menu-item-handler% + [gtk item-gtk] + [menu this] + [menu-item i] + [parent this])]) + (set! items (append items (list (list item item-gtk label chckable?)))) + (adjust-shortcut item-gtk label))) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk)))) (define/public (append-separator) - (let ([item-gtk (gtk_separator_menu_item_new)]) - (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) - (gtk_menu_shell_append gtk item-gtk) - (gtk_widget_show item-gtk))) + (atomically + (let ([item-gtk (gtk_separator_menu_item_new)]) + (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk)))) (def/public-unimplemented select) (def/public-unimplemented get-font) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 5a54ed8b..7b34a75b 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -57,7 +57,7 @@ (inherit set-size get-gtk) (super-new [parent parent] - [gtk (gtk_fixed_new)] ; (gtk_alignment_new 0.0 0.0 1.0 1.0)] + [gtk (as-gtk-allocation (gtk_fixed_new))] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 011e5426..8bb12b75 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -44,26 +44,28 @@ (inherit set-auto-size on-set-focus) - (define gtk (if (memq 'horizontal style) - (gtk_hbox_new #f 0) - (gtk_vbox_new #f 0))) + (define gtk (as-gtk-allocation + (if (memq 'horizontal style) + (gtk_hbox_new #f 0) + (gtk_vbox_new #f 0)))) (define radio-gtks (for/list ([lbl (in-list labels)]) - (let ([radio-gtk (cond - [(string? lbl) - (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] - [(send lbl ok?) - (let ([pixbuf (bitmap->pixbuf lbl)]) - (let ([radio-gtk (gtk_radio_button_new #f)] - [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) - (release-pixbuf pixbuf) - (gtk_container_add radio-gtk image-gtk) - (gtk_widget_show image-gtk) - radio-gtk))] - [else - (gtk_radio_button_new_with_mnemonic #f "")])]) - (gtk_box_pack_start gtk radio-gtk #t #t 0) - (gtk_widget_show radio-gtk) - radio-gtk))) + (atomically + (let ([radio-gtk (cond + [(string? lbl) + (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] + [(send lbl ok?) + (let ([pixbuf (bitmap->pixbuf lbl)]) + (let ([radio-gtk (gtk_radio_button_new #f)] + [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_add radio-gtk image-gtk) + (gtk_widget_show image-gtk) + radio-gtk))] + [else + (gtk_radio_button_new_with_mnemonic #f "")])]) + (gtk_box_pack_start gtk radio-gtk #t #t 0) + (gtk_widget_show radio-gtk) + radio-gtk)))) (for ([radio-gtk (in-list (cdr radio-gtks))]) (let ([g (gtk_radio_button_get_group (car radio-gtks))]) (gtk_radio_button_set_group radio-gtk g))) @@ -108,8 +110,9 @@ (if (= i -1) (when (pair? radio-gtks) (unless dummy-gtk - (set! dummy-gtk (gtk_radio_button_new - (gtk_radio_button_get_group (car radio-gtks))))) + (set! dummy-gtk (as-gtk-allocation + (gtk_radio_button_new + (gtk_radio_button_get_group (car radio-gtks)))))) (gtk_toggle_button_set_active dummy-gtk #t)) (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) (set! no-clicked? #f))) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 48a0098d..edcf5ad9 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -39,9 +39,10 @@ (inherit get-gtk set-auto-size) (super-new [parent parent] - [gtk (if (memq 'vertical style) - (gtk_vscale_new #f) - (gtk_hscale_new #f))] + [gtk (as-gtk-allocation + (if (memq 'vertical style) + (gtk_vscale_new #f) + (gtk_hscale_new #f)))] [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index c157df50..1785cb1e 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -17,6 +17,10 @@ g_object_ref g_object_unref + gobject-ref + gobject-unref + as-gobject-allocation + as-gtk-allocation as-gtk-window-allocation @@ -90,6 +94,14 @@ (define-gobj g_object_unref (_fun _pointer -> _void)) (define-gobj g_object_ref_sink (_fun _pointer -> _pointer)) +(define gobject-unref ((deallocator) g_object_unref)) +(define gobject-ref ((allocator gobject-unref) g_object_ref)) + +(define-syntax-rule (as-gobject-allocation expr) + ((gobject-allocator (lambda () expr)))) + +(define gobject-allocator (allocator gobject-unref)) + (define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) (define gtk-destroy ((deallocator) (lambda (v) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index cf407082..4ee5f740 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -1,12 +1,12 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" + "../../lock.rkt" "../common/queue.rkt" "queue.rkt" "utils.rkt" "types.rkt") -(unsafe!) (provide widget% gtk->wx @@ -25,13 +25,17 @@ (define-gtk gtk_widget_destroy (_fun _pointer -> _void)) - (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) +(define-signal-handler connect-destroy "destroy" + (_fun _GtkWidget _pointer -> _void) + (lambda (gtk cell) + (free-immobile-cell cell))) + (define widget% (class object% (init gtk @@ -52,10 +56,12 @@ (super-new) - (let ([cell (malloc-immobile-cell (make-weak-box this))]) - (g_object_set_data gtk "wx" cell) - (for ([gtk (in-list extra-gtks)]) - (g_object_set_data gtk "wx" cell))))) + (atomically + (let ([cell (malloc-immobile-cell (make-weak-box this))]) + (g_object_set_data gtk "wx" cell) + (for ([gtk (in-list extra-gtks)]) + (g_object_set_data gtk "wx" cell)) + (connect-destroy gtk cell))))) (define (gtk->wx gtk) (let ([ptr (g_object_get_data gtk "wx")]) From e2687511b3aa7bf90ca6c854cfb725721a641361 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 08:54:34 -0600 Subject: [PATCH 159/462] another try at fixing gtk dialog placement original commit: 647ce060ab1abe89eb22d0f974b93d619d2fc612 --- collects/mred/private/wx/gtk/dialog.rkt | 5 +---- collects/mred/private/wx/gtk/frame.rkt | 2 ++ collects/mred/private/wx/gtk/window.rkt | 10 ++++++---- collects/mred/private/wxtop.rkt | 2 +- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 5cf001f8..3de209a7 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -57,10 +57,7 @@ (super direct-show on?)) (define/override (center dir wrt) - ;; We're supposed to use gtk_window_set_position() for dialogs, - ;; but we must be doing something else wrong so that it doesn't - ;; work. - (if #f ; (eq? dir 'both) + (if (eq? dir 'both) (gtk_window_set_position (get-gtk) (if (get-parent) GTK_WIN_POS_CENTER_ON_PARENT diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index df5eda5e..1be511eb 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -180,6 +180,8 @@ (define/override (get-dialog-level) 0) (define/public (frame-relative-dialog-status win) #f) + (define/override (get-unset-pos) -11111) + (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 34ab5f9f..c4fda419 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -287,11 +287,13 @@ [extra-gtks extra-gtks] [parent parent]) - (define save-x 0) - (define save-y 0) + (define save-x (get-unset-pos)) + (define save-y (get-unset-pos)) (define save-w 0) (define save-h 0) + (define/public (get-unset-pos) 0) + (connect-size-allocate gtk) (when add-to-parent? @@ -399,8 +401,8 @@ (unless no-show? (show #t)) - (define/public (get-x) save-x) - (define/public (get-y) save-y) + (define/public (get-x) (if (= save-x -11111) 0 save-x)) + (define/public (get-y) (if (= save-y -11111) 0 save-y)) (define/public (get-width) save-w) (define/public (get-height) save-h) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 6a86a835..781a3278 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -345,7 +345,7 @@ (set! last-height correct-h) (set! already-trying? #t) (enforce-size -1 -1 -1 -1 1 1) - (set-size -1 -1 correct-w correct-h) + (set-size -11111 -11111 correct-w correct-h) (enforce-size min-w min-h (if sx? -1 min-w) (if sy? -1 min-h) 1 1) From 4cc2244c0c6f940267fc503741ea879080bb82d9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 11:43:06 -0600 Subject: [PATCH 160/462] streamline gtk widget repositioning original commit: 7edbdd8a5a13b826977d5531fee4e16e909d2e9e --- collects/mred/private/wx/gtk/canvas.rkt | 9 +++++++++ collects/mred/private/wx/gtk/frame.rkt | 7 ++++--- collects/mred/private/wx/gtk/group-panel.rkt | 2 +- collects/mred/private/wx/gtk/panel.rkt | 2 +- collects/mred/private/wx/gtk/tab-panel.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 10 ++++++++-- 6 files changed, 24 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 8d71ad50..dd256a66 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -41,6 +41,8 @@ (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_widget_set_double_buffered (_fun _GtkWidget _gboolean -> _void)) + (define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject (define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment)) (define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void) @@ -282,6 +284,7 @@ (GtkRequisition-height r)))) (connect-expose client-gtk) + #;(gtk_widget_set_double_buffered client-gtk #f) (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK @@ -329,6 +332,12 @@ (set! paint-queued? #f) (set! now-drawing? #t) (send dc reset-backing-retained) ; clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) (on-paint) (set! now-drawing? #f) (when refresh-after-drawing? diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 1be511eb..b1dfd74b 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -136,8 +136,9 @@ (when label (gtk_window_set_title gtk label)) - (define/public (set-child-position child-gtk x y) - (gtk_fixed_move panel-gtk child-gtk x y)) + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move panel-gtk child-gtk x y) + (gtk_widget_set_size_request child-gtk w h)) (define/public (on-close) (void)) @@ -255,7 +256,7 @@ (direct-show #f)) (define/override (on-client-size w h) - (on-size w h)) + (void)) (define/augment (is-enabled-to-root?) #t) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index 4c718d49..c864a442 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -53,4 +53,4 @@ (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move client-gtk child-gtk x y) - (super set-child-size child-gtk x y w h)))) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 7b34a75b..54ccd948 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -64,4 +64,4 @@ (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move gtk child-gtk x y) - (super set-child-size child-gtk x y w h)))) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index c2e304e9..b0985916 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -165,4 +165,4 @@ (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move client-gtk child-gtk x y) - (super set-child-size child-gtk x y w h)))) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index c4fda419..85ab4897 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -332,13 +332,18 @@ (gtk_widget_set_size_request child-gtk w h) (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) + (define on-size-queued? #f) (define/public (remember-size w h) ;; called in event-pump thread (unless (and (= save-w w) (= save-h h)) (set! save-w w) (set! save-h h) - (queue-window-event this (lambda () (on-size w h))))) + (unless on-size-queued? + (set! on-size-queued? #t) + (queue-window-event this (lambda () + (set! on-size-queued? #f) + (on-size w h)))))) (define client-delta-w 0) (define client-delta-h 0) @@ -348,7 +353,8 @@ ;; Called in the Gtk event-loop thread ;(set! client-delta-w (max min-client-delta-w (- save-w w))) ;(set! client-delta-h (max min-client-delta-h (- save-h h))) - (queue-window-event this (lambda () (on-size 0 0)))) + #;(queue-window-event this (lambda () (on-size 0 0))) + (void)) (define/public (tentative-client-size w h) (void)) From a95188844601b593b95c1ec185074a3e119caed4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 12:00:00 -0600 Subject: [PATCH 161/462] fix frame stretchability original commit: 7a3a005644a2dde13c3f78706b7258a1eaa3670a --- collects/mred/private/mrtop.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index a99ca6a1..2c1499ec 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -136,7 +136,7 @@ [do-set-status-text (lambda (s) (send status-message set-label s))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor)))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () mid-panel) mismatches label parent arrow-cursor)))) (define frame% From cb571363a96cda9e8accab2ed738c83b55e9e6a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 13:53:02 -0600 Subject: [PATCH 162/462] misc repairs original commit: 0114b7a4a5966fea451c92c532bbb86bb638266e --- collects/mred/private/mrtop.rkt | 13 ++++--- collects/mred/private/mrwindow.rkt | 18 ++++++---- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/canvas.rkt | 2 +- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 30 ++++++++-------- collects/mred/private/wx/cocoa/menu-bar.rkt | 38 +++++++++++++------- collects/mred/private/wx/cocoa/menu-item.rkt | 2 +- collects/mred/private/wx/cocoa/menu.rkt | 5 +-- collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 2 +- collects/mred/private/wx/cocoa/window.rkt | 17 +++++++-- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/procs.rkt | 2 +- 16 files changed, 86 insertions(+), 55 deletions(-) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 2c1499ec..ca693a9b 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -49,7 +49,7 @@ (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) - (inherit show) + (inherit show set-get-outer-panel) (rename [super-set-label set-label]) (private [wx-object->proxy @@ -131,12 +131,15 @@ top-level))]) (public [do-create-status-line (lambda () - (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) - (send status-message stretchable-in-x #t))] + (unless status-message + (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) + (send status-message stretchable-in-x #t)))] [do-set-status-text (lambda (s) - (send status-message set-label s))]) + (when status-message + (send status-message set-label s)))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () mid-panel) mismatches label parent arrow-cursor)))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor) + (set-get-outer-panel (lambda () mid-panel))))) (define frame% diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 6572640e..318ae69d 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -21,7 +21,9 @@ window<%> (protect window%-keywords) subwindow<%> - (protect make-window%)) + (protect make-window%) + + (protect set-get-outer-panel)) (define area<%> (interface () @@ -36,6 +38,9 @@ [stretchable-width no-val] [stretchable-height no-val]) + (define-local-member-name + set-get-outer-panel) + (define area% (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt ;; for keyword use: @@ -49,15 +54,16 @@ (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (mismatches)) (private-field - [get-wx-panel get-wx-pan] + [get-wx-outer-panel get-wx-pan] [parent prnt]) (public + [set-get-outer-panel (lambda (get-wx-outer-pan) (set! get-wx-outer-panel get-wx-outer-pan))] [get-parent (lambda () parent)] [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))] - [(minw min-width) (param get-wx-panel min-width)] - [(minh min-height) (param get-wx-panel min-height)] - [(sw stretchable-width) (param get-wx-panel stretchable-in-x)] - [(sh stretchable-height) (param get-wx-panel stretchable-in-y)] + [(minw min-width) (param get-wx-outer-panel min-width)] + [(minh min-height) (param get-wx-outer-panel min-height)] + [(sw stretchable-width) (param get-wx-outer-panel stretchable-in-x)] + [(sh stretchable-height) (param get-wx-outer-panel stretchable-in-y)] [get-graphical-min-size (entry-point (lambda () (if (wx . is-a? . wx-basic-panel<%>) (apply values (send wx get-graphical-min-size)) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index dbff38f0..924df485 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -39,7 +39,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyButton alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h))))]) (when button-type (tellv cocoa setButtonType: #:type _int button-type)) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 1c4467a1..99598d44 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -252,7 +252,7 @@ FrameView)] [else NSView]) alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize (max w (* 2 x-margin)) (max h (* 2 y-margin))))))] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 71b79707..b8dab3b9 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -35,7 +35,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyPopUpButton alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h)) pullsDown: #:type _BOOL #f))]) (for ([lbl (in-list choices)] diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 39510db6..d4f00a6d 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -92,12 +92,6 @@ (and front (send front get-eventspace))))) -(define (init-pos x y) - (if (and (= x -11111) - (= y -11111)) - (values 0 0) - (values x y))) - (define frame% (class window% (init parent @@ -108,7 +102,8 @@ (inherit get-cocoa get-parent get-eventspace - pre-on-char pre-on-event) + pre-on-char pre-on-event + get-x get-y) (super-new [parent parent] [cocoa @@ -116,13 +111,12 @@ is-dialog? parent (not (send parent frame-is-dialog?)))] - [init-rect (let-values ([(x y) (init-pos x y)]) - (make-NSRect (make-NSPoint x y) - (make-NSSize (max 30 w) - (max (if (memq 'no-caption style) - 0 - 22) - h))))]) + [init-rect (make-NSRect (make-init-point x y) + (make-NSSize (max 30 w) + (max (if (memq 'no-caption style) + 0 + 22) + h)))]) (let ([c (as-objc-allocation (tell (tell (if is-sheet? MyPanel @@ -151,6 +145,8 @@ (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) + (move -11111 (if (= y -11111) 0 y)) + (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) (define/override (get-cocoa-content) @@ -319,7 +315,9 @@ (make-NSSize w h)) display: #:type _BOOL #t))) (define/override (move x y) - (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y)))) + (let ([x (if (= x -11111) (get-x) x)] + [y (if (= y -11111) (get-y) y)]) + (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y))))) (define/override (center dir wrt) (let ([f (tell #:type _NSRect cocoa frame)] @@ -366,7 +364,7 @@ (define/public (on-activate on?) (void)) - (define/public (set-icon bm1 bm2 mode) (void)) ;; FIXME + (define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME (define/override (call-pre-on-event w e) (pre-on-event w e)) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 1ca3d147..df57b133 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -4,6 +4,7 @@ ffi/unsafe/objc (only-in racket/list take drop) "../../syntax.rkt" + "../../lock.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -109,28 +110,38 @@ (tellv app setMainMenu: cocoa-mb) (set! the-apple-menu apple))) +(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f) + (defclass menu-bar% object% (define menus null) (def/public-unimplemented number) - (def/public-unimplemented enable-top) + (define/public (enable-top pos on?) + (set-box! (cddr (list-ref menus pos)) on?) + (when (eq? current-mb this) + (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)) + setEnabled: #:type _BOOL on?))) (define/public (delete which pos) - (set! menus (let loop ([menus menus] - [pos pos]) - (cond - [(null? menus) menus] - [(zero? pos) (cdr menus)] - [else (cons (car menus) - (loop (cdr menus) - pos))])))) + (atomically + (when (eq? current-mb this) + (tellv cocoa-mb removeItem: + (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)))) + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + (sub1 pos)))]))))) (public [append-menu append]) (define (append-menu menu title) - (set! menus (append menus (list (cons menu title)))) + (set! menus (append menus (list (list* menu title (box #t))))) (send menu set-parent this) (when (eq? current-mb this) - (send menu install cocoa-mb title))) + (send menu install cocoa-mb title #t))) (define/public (install) (let loop () @@ -138,7 +149,7 @@ (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) (loop))) (for-each (lambda (menu) - (send (car menu) install cocoa-mb (cdr menu))) + (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu)))) menus) (set! current-mb this)) @@ -151,7 +162,8 @@ (define/public (set-label-top pos str) (set! menus (append (take menus pos) - (list (cons (car (list-ref menus pos)) str)) + (let ([i (list-ref menus pos)]) + (list (cons (car i) (cons str (cddr i))))) (drop menus (add1 pos)))) (when (eq? current-mb this) (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 2356214c..fc8e75df 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -49,7 +49,7 @@ (define/public (install menu) (if submenu - (send submenu install menu label) + (send submenu install menu label enabled?) (let ([item (as-objc-allocation (tell (tell MyMenuItem alloc) initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 2b64cc89..a671fffd 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -49,9 +49,10 @@ (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) items))) - (define/public (install cocoa-parent label) + (define/public (install cocoa-parent label enabled?) (create-menu label) - (tellv cocoa-parent addItem: cocoa)) + (tellv cocoa-parent addItem: cocoa) + (tellv cocoa setEnabled: #:type _BOOL enabled?)) (define popup-box #f) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 84423107..5602219a 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -62,6 +62,6 @@ [cocoa (as-objc-allocation (tell (tell NSView alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h))))] [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index f66c2ddd..e9e66c15 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -65,7 +65,7 @@ (define-unimplemented special-control-key) -(define-unimplemented special-option-key) +(define (special-option-key on?) (void)) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index fce42e5c..95b1ef46 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -73,7 +73,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyMatrix alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h)) mode: #:type _int NSRadioModeMatrix cellClass: (if (andmap string? labels) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 9a11f8a4..cad55b78 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -41,7 +41,7 @@ (tellv cocoa addTabViewItem: item) item))) (let ([sz (tell #:type _NSSize cocoa minimumSize)]) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) sz))) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz))) (tellv cocoa setDelegate: cocoa) (define content-cocoa diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index cc2df439..059e1492 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -24,7 +24,8 @@ queue-window-event queue-window*-event request-flush-delay - cancel-flush-delay) + cancel-flush-delay + make-init-point) (define-local-member-name flip-client) @@ -313,8 +314,10 @@ (set-box! h (->long (NSSize-height s))))) (define/public (set-size x y w h) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) - (make-NSSize w h)))) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) + (make-NSSize w h))))) (define/public (move x y) (set-size x y (get-width) (get-height))) @@ -449,3 +452,11 @@ (set! depth (sub1 depth)) (tellv cocoa-win enableFlushWindow) (remove-event-boundary-callback! req))))) + +(define (make-init-point x y) + (make-NSPoint (if (= x -11111) + 0 + x) + (if (= y -11111) + 0 + y))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index b1dfd74b..d4b6cb68 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -260,7 +260,7 @@ (define/augment (is-enabled-to-root?) #t) - (define/public (set-icon bm mask mode) (void)) ;; FIXME + (define/public (set-icon bm mask [mode 'both]) (void)) ;; FIXME (define/override (call-pre-on-event w e) (pre-on-event w e)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 32639281..7f48f765 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -64,7 +64,7 @@ can-show-print-setup?) (define-unimplemented special-control-key) -(define-unimplemented special-option-key) +(define (special-option-key on?) (void)) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) From be50496117dcead2b4504ba725a32c10066fb3a5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 16:49:39 -0600 Subject: [PATCH 163/462] use Cairo's Quartz back-end for canvas buffering under Mac OS X + makes text rending look much better - makes drawing to a bitmap% different than drawing onscreen original commit: 2dba600d59a97271f8ee4517c6b4e1efb695e94f --- collects/mred/private/wx/cocoa/dc.rkt | 28 +++++++++++++++++++ .../mred/private/wx/common/backing-dc.rkt | 12 +++++--- 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 2dab797f..2737d8a4 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -33,6 +33,30 @@ (define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) +(define quartz-bitmap% + (class object% + (init w h b&w? alpha?) + (super-new) + (define s + (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32 + w + h)) + + (define/public (ok?) #t) + (define/public (is-color?) #t) + + (define width w) + (define height h) + (define/public (get-width) width) + (define/public (get-height) height) + + (define/public (get-cairo-surface) s) + + (define/public (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -40,6 +64,10 @@ (super-new) + ;; Use a quartz bitmap so that text looks good: + (define/override (get-bitmap%) quartz-bitmap%) + (define/override (can-combine-text? sz) #t) + (define/override (get-backing-size xb yb) (send canvas get-backing-size xb yb)) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 7280e68d..922894e0 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -15,7 +15,8 @@ on-backing-flush start-backing-retained end-backing-retained - reset-backing-retained) + reset-backing-retained + get-bitmap%) (define-local-member-name get-backing-size @@ -23,7 +24,8 @@ on-backing-flush start-backing-retained end-backing-retained - reset-backing-retained) + reset-backing-retained + get-bitmap%) (define backing-dc% (class (dc-mixin bitmap-dc-backend%) @@ -83,12 +85,14 @@ (log-error "unbalanced end-on-paint") (set! retained-counter (sub1 retained-counter)))))) + (define/public (get-bitmap%) bitmap%) + (define/override (get-cr) (or retained-cr (let ([w (box 0)] [h (box 0)]) (get-backing-size w h) - (let ([bm (get-backing-bitmap (unbox w) (unbox h))]) + (let ([bm (get-backing-bitmap (get-bitmap%) (unbox w) (unbox h))]) (internal-set-bitmap bm #t)) (let ([cr (super get-cr)]) (set! retained-cr cr) @@ -110,7 +114,7 @@ (when (zero? flush-suspends) (queue-backing-flush)))))) -(define (get-backing-bitmap w h) +(define (get-backing-bitmap bitmap% w h) (make-object bitmap% w h #f #t)) (define (release-backing-bitmap bm) From 35aaa3a0fb3e6754009e9327e971d25000b57446 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Aug 2010 10:49:53 -0600 Subject: [PATCH 164/462] cocoa cursors original commit: 40c1c2ffef5f5ee4972ac6ef98b050e13cd8ab34 --- collects/mred/private/kernel.rkt | 5 +- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/canvas.rkt | 14 ++- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/cursor.rkt | 88 ++++++++++++++++--- collects/mred/private/wx/cocoa/frame.rkt | 41 ++++++++- collects/mred/private/wx/cocoa/gauge.rkt | 2 +- .../mred/private/wx/cocoa/group-panel.rkt | 4 +- collects/mred/private/wx/cocoa/list-box.rkt | 2 +- collects/mred/private/wx/cocoa/message.rkt | 4 +- collects/mred/private/wx/cocoa/panel.rkt | 6 +- collects/mred/private/wx/cocoa/platform.rkt | 3 - collects/mred/private/wx/cocoa/procs.rkt | 8 -- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/slider.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 3 +- collects/mred/private/wx/cocoa/window.rkt | 39 +++++++- collects/mred/private/wx/common/cursor.rkt | 3 + collects/mred/private/wx/common/local.rkt | 6 +- collects/mred/private/wx/common/queue.rkt | 40 ++++++++- collects/mred/private/wx/gtk/frame.rkt | 3 + collects/mred/private/wx/gtk/platform.rkt | 3 - collects/mred/private/wx/gtk/procs.rkt | 8 -- collects/mred/private/wx/platform.rkt | 3 - collects/mred/private/wx/win32/platform.rkt | 3 - collects/mred/private/wx/win32/procs.rkt | 3 - collects/mred/private/wxlitem.rkt | 14 +-- collects/tests/gracket/item.rkt | 2 +- 28 files changed, 240 insertions(+), 75 deletions(-) diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 419c6408..114af2bf 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -34,4 +34,7 @@ eventspace-handler-thread queue-callback middle-queue-key - get-top-level-windows) + get-top-level-windows + begin-busy-cursor + is-busy? + end-busy-cursor) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 924df485..93e87017 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -24,7 +24,7 @@ (define MIN-BUTTON-WIDTH 72) (define-objc-class MyButton NSButton - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (clicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 99598d44..9e7dff5d 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -47,7 +47,7 @@ (tellv ctx restoreGraphicsState))))))) (define-objc-class MyView NSView - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (drawRect: [_NSRect r]) (when wxb @@ -127,7 +127,7 @@ (tellv ctx restoreGraphicsState))))) (define-objc-class MyComboBox NSComboBox - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) #:protocols (NSComboBoxDelegate) [wxb] (-a _void (drawRect: [_NSRect r]) @@ -172,7 +172,8 @@ move get-x get-y on-size register-as-child - get-size get-position) + get-size get-position + set-focus) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) @@ -607,6 +608,10 @@ (define/override (definitely-wants-event? e) ;; Called in Cocoa event-handling mode + (when (and is-combo? + (e . is-a? . mouse-event%) + (send e button-down? 'left)) + (set-focus)) (or (not is-combo?) (e . is-a? . key-event%) (not (send e button-down? 'left)) @@ -670,6 +675,9 @@ (when is-combo? (set-box! xb (- (unbox xb) 22)))) + (define/override (get-cursor-width-delta) + (if is-combo? 22 0)) + (define/public (is-flipped?) (tell #:type _BOOL (get-cocoa-content) isFlipped)) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index b8dab3b9..d9caac07 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -19,7 +19,7 @@ (import-class NSPopUpButton) (define-objc-class MyPopUpButton NSPopUpButton - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (clicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt index 6854f280..c3235333 100644 --- a/collects/mred/private/wx/cocoa/cursor.rkt +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -1,14 +1,53 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign - scheme/class) -(unsafe!) -(objc-unsafe!) +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/draw + "image.rkt" + "types.rkt" + "../common/local.rkt") -(provide cursor-driver%) +(provide cursor-driver% + arrow-cursor-handle + get-wait-cursor-handle) (import-class NSCursor) +(define wait #f) +(define bullseye #f) +(define blank #f) +(define size-ne/sw #f) +(define size-nw/se #f) + +(define-syntax-rule (image-cursor id draw-proc) + (or id + (begin + (set! id (make-image-cursor draw-proc)) + id))) + +(define (make-image-cursor draw-proc) + (let* ([bm (make-object bitmap% 16 16 #f #t)] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing 'aligned) + (draw-proc dc 16 16) + (send dc set-bitmap #f) + (let ([image (bitmap->image bm)]) + (tell (tell NSCursor alloc) + initWithImage: image + hotSpot: #:type _NSPoint (make-NSPoint 8 8))))) + +(define arrow-cursor-handle (tell NSCursor arrowCursor)) +(define (get-wait-cursor-handle) + (image-cursor wait + (lambda (dc w h) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 5 0 6 4) + (send dc draw-rectangle 5 12 6 4) + (send dc set-brush "white" 'solid) + (send dc draw-ellipse 3 3 10 10) + (send dc draw-line 7 5 7 8) + (send dc draw-line 7 8 9 8)))) + (define cursor-driver% (class object% (define handle #f) @@ -16,7 +55,7 @@ (define/public (set-standard sym) (case sym [(arrow) - (set! handle (tell NSCursor arrowCursor))] + (set! handle arrow-cursor-handle)] [(cross) (set! handle (tell NSCursor crosshairCursor))] [(hand) @@ -26,9 +65,38 @@ [(size-n/s) (set! handle (tell NSCursor resizeUpDownCursor))] [(size-e/w) - (set! handle (tell NSCursor resizeLeftRightCursor))])) + (set! handle (tell NSCursor resizeLeftRightCursor))] + [(size-nw/se) + (set! handle + (image-cursor size-nw/se (lambda (dc w h) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 0 3 0 0) + (send dc draw-line 0 0 3 0) + (send dc draw-line 12 15 15 15) + (send dc draw-line 15 15 15 12))))] + [(size-ne/sw) + (set! handle + (image-cursor size-ne/sw (lambda (dc w h) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 12 0 15 0) + (send dc draw-line 15 0 15 3) + (send dc draw-line 0 12 0 15) + (send dc draw-line 0 15 3 15))))] + [(watch) + (set! handle (get-wait-cursor-handle))] + [(bullseye) + (set! handle + (image-cursor bullseye (lambda (dc w h) + (send dc draw-ellipse 1 1 (- w 2) (- h 2)) + (send dc draw-ellipse 4 4 (- w 8) (- h 8)) + (send dc draw-ellipse 7 7 2 2))))] + [(blank) + (set! handle (image-cursor blank void))])) (define/public (ok?) (and handle #t)) - (super-new))) + (define/public (get-handle) handle) + (super-new))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index d4f00a6d..3c95a7b9 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -9,6 +9,7 @@ "window.rkt" "queue.rkt" "menu-bar.rkt" + "cursor.rkt" "../../syntax.rkt" "../common/queue.rkt" "../../lock.rkt") @@ -59,6 +60,7 @@ (let ([wx (->wx wxb)]) (when wx (set! front wx) + (send wx install-wait-cursor) (send wx install-mb) (send wx notify-responder #t) (queue-window-event wx (lambda () @@ -67,7 +69,9 @@ (when wxb (let ([wx (->wx wxb)]) (when wx - (when (eq? front wx) (set! front #f)) + (when (eq? front wx) + (set! front #f) + (send wx uninstall-wait-cursor)) (send empty-mb install) (send wx notify-responder #f) (queue-window-event wx (lambda () @@ -237,8 +241,11 @@ [next (tellv next makeKeyWindow)] [root-fake-frame (send root-fake-frame install-mb)] [else (void)])))) - (register-frame-shown this on?)))) - + (register-frame-shown this on?) + (when on? + (let ([b (eventspace-wait-cursor-count (get-eventspace))]) + (set-wait-cursor-mode (not (zero? b)))))))) + (define/override (show on?) (when on? (when (eventspace-shutdown? (get-eventspace)) @@ -267,6 +274,17 @@ (define is-main? #f) (define first-responder #f) + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child)) + + (define/override (set-cursor c) + (when saved-child + (send saved-child set-cursor c))) + (define/public (notify-responder on?) (set! is-main? on?) (when first-responder @@ -286,6 +304,23 @@ (when is-main? (do-notify-responder wx on?))) + (define/public (install-wait-cursor) + (when (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tellv (get-wait-cursor-handle) set))) + + (define/public (uninstall-wait-cursor) + (when (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tellv arrow-cursor-handle set))) + + (define/public (set-wait-cursor-mode on?) + (if on? + (tell cocoa disableCursorRects) + (tell cocoa enableCursorRects)) + (when (eq? this front) + (if on? + (install-wait-cursor) + (uninstall-wait-cursor)))) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index 04be1294..d4eeb201 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -19,7 +19,7 @@ (import-class NSProgressIndicator) (define-objc-class MyProgressIndicator NSProgressIndicator - #:mixins (KeyMouseResponder) + #:mixins (KeyMouseResponder CursorDisplayer) [wxb]) (defclass gauge% item% diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index 0b367e47..8c70afe1 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -15,7 +15,7 @@ (import-class NSBox) (define-objc-class MyBox NSBox - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb]) (defclass group-panel% (panel-mixin window%) @@ -37,6 +37,8 @@ (define/override (get-cocoa-content) (tell (get-cocoa) contentView)) + (define/override (get-cocoa-cursor-content) + (get-cocoa)) (define/public (set-label l) (tellv (get-cocoa) setTitle: #:type _NSString l))) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 6b86fd00..ea9ee562 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -22,7 +22,7 @@ (import-protocol NSTableViewDataSource) (define-objc-class MyTableView NSTableView - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (let ([wx (->wx wxb)]) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 0fce8fc5..1f2510da 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -32,11 +32,11 @@ "NSApplicationPath"))) (define-objc-class MyTextField NSTextField - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb]) (define-objc-class MyImageView NSImageView - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb]) (defclass message% item% diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 5602219a..ec461c46 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -14,6 +14,10 @@ (import-class NSView) +(define-objc-class MyPanelView NSView + #:mixins (CursorDisplayer) + [wxb]) + (define (panel-mixin %) (class % (inherit register-as-child) @@ -61,7 +65,7 @@ (super-new [parent parent] [cocoa (as-objc-allocation - (tell (tell NSView alloc) + (tell (tell MyPanelView alloc) initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h))))] [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 77bc402c..f6e408e8 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -61,9 +61,6 @@ file-selector is-color-display? get-display-depth - begin-busy-cursor - is-busy? - end-busy-cursor has-x-selection? hide-cursor bell diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index e9e66c15..2b4cc3db 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -49,9 +49,6 @@ display-size bell hide-cursor - end-busy-cursor - is-busy? - begin-busy-cursor get-display-depth is-color-display? file-selector @@ -113,11 +110,6 @@ (define (hide-cursor) (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) -(define busy-count 0) -(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count)))) -(define (is-busy?) (positive? busy-count)) -(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count)))) - (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define-unimplemented file-selector) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 95b1ef46..364e1169 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -24,7 +24,7 @@ (define NSListModeMatrix 2) (define-objc-class MyMatrix NSMatrix - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (clicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 19f086bb..7af719fb 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -22,7 +22,7 @@ (import-class NSSlider) (define-objc-class MySlider NSSlider - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (changed: [_id sender]) (let ([wx (->wx wxb)]) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index cad55b78..58beb5f6 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -18,7 +18,7 @@ (import-protocol NSTabViewDelegate) (define-objc-class MyTabView NSTabView - #:mixins (FocusResponder KeyMouseResponder) + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) #:protocols (NSTabViewDelegate) [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) @@ -51,6 +51,7 @@ (tell #:type _void cocoa addSubview: content-cocoa) (define/override (get-cocoa-content) content-cocoa) + (define/override (get-cocoa-cursor-content) cocoa) (define/override (set-size x y w h) (super set-size x y w h) (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 059e1492..70caeb77 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -8,6 +8,8 @@ "types.rkt" "keycode.rkt" "pool.rkt" + "cursor.rkt" + "../common/local.rkt" "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" @@ -20,6 +22,7 @@ FocusResponder KeyMouseResponder + CursorDisplayer queue-window-event queue-window*-event @@ -107,6 +110,13 @@ (queue-window-event wx (lambda () (send wx key-event-as-string str)))))]) +(define-objc-mixin (CursorDisplayer Superclass) + [wxb] + [-a _void (resetCursorRects) + (let ([wx (->wx wxb)]) + (when wx + (send wx reset-cursor-rects)))]) + (define (do-key-event wxb event) (let ([wx (->wx wxb)]) (and @@ -205,6 +215,7 @@ (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) + (define/public (get-cocoa-cursor-content) (get-cocoa-content)) (define/public (get-cocoa-window) (send parent get-cocoa-window)) (define/public (get-wx-window) (send parent get-wx-window)) @@ -314,8 +325,8 @@ (set-box! h (->long (NSSize-height s))))) (define/public (set-size x y w h) - (let ([x (if (= x -11111) 0 x)] - [y (if (= y -11111) 0 y)]) + (let ([x (if (= x -11111) (get-x) x)] + [y (if (= y -11111) (get-y) y)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (make-NSSize w h))))) (define/public (move x y) @@ -409,8 +420,28 @@ (def/public-unimplemented fit) - (define/public (set-cursor c) (void)) - + (define cursor-handle #f) + (define/public (set-cursor c) + (let ([h (if c + (send (send c get-driver) get-handle) + #f)]) + (unless (eq? h cursor-handle) + (atomically + (set! cursor-handle h) + (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content)))))) + (define/public (reset-cursor-rects) + ;; called in event-pump thread + (when cursor-handle + (let ([content (get-cocoa-cursor-content)]) + (let* ([r (tell #:type _NSRect content frame)] + [r (make-NSRect (make-NSPoint 0 0) + (make-NSSize + (- (NSSize-width (NSRect-size r)) + (get-cursor-width-delta)) + (NSSize-height (NSRect-size r))))]) + (tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle))))) + (define/public (get-cursor-width-delta) 0) + (define/public (gets-focus?) #f) (def/public-unimplemented centre))) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt index f2767586..fb879edf 100644 --- a/collects/mred/private/wx/common/cursor.rkt +++ b/collects/mred/private/wx/common/cursor.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/draw + "local.rkt" (only-in "../platform.rkt" cursor-driver%) "../../syntax.rkt") @@ -32,5 +33,7 @@ c)] (init-name 'cursor%))) + (define/public (get-driver) driver) + (def/public (ok?) (send driver ok?)) (super-new)) diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt index 00b39c08..6ffb76cb 100644 --- a/collects/mred/private/wx/common/local.rkt +++ b/collects/mred/private/wx/common/local.rkt @@ -5,4 +5,8 @@ (define-local-member-name ;; clipboard-client%: - get-client-eventspace) + get-client-eventspace + + ;; cursor% + get-driver) + diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index bf93f755..2f52f60a 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -26,6 +26,7 @@ eventspace-shutdown? main-eventspace? eventspace-handler-thread + eventspace-wait-cursor-count queue-callback middle-queue-key @@ -39,7 +40,11 @@ other-modal? queue-quit-event - queue-prefs-event) + queue-prefs-event + + begin-busy-cursor + end-busy-cursor + is-busy?) ;; ------------------------------------------------------------ ;; This module must be instantiated only once: @@ -116,7 +121,13 @@ ;; ------------------------------------------------------------ ;; Eventspaces -(define-struct eventspace (handler-thread queue-proc frames-hash done-evt [shutdown? #:mutable] done-sema) +(define-struct eventspace (handler-thread + queue-proc + frames-hash + done-evt + [shutdown? #:mutable] + done-sema + [wait-cursor-count #:mutable]) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -270,7 +281,8 @@ frames (semaphore-peek-evt done-sema) #f - done-sema)] + done-sema + 0)] [cb-box (box #f)]) (parameterize ([current-cb-box cb-box]) (scheme_add_managed (current-custodian) @@ -390,3 +402,25 @@ (define (queue-prefs-event) ;; called in event-pump thread (queue-event main-eventspace (application-pref-handler) 'med)) + +(define (begin-busy-cursor) + (let ([e (current-eventspace)]) + (atomically + (set-eventspace-wait-cursor-count! + e + (add1 (eventspace-wait-cursor-count e))) + (when (= (eventspace-wait-cursor-count e) 1) + (for ([e (in-list (get-top-level-windows))]) + (send e set-wait-cursor-mode #t)))))) + +(define (end-busy-cursor) + (let ([e (current-eventspace)]) + (atomically + (set-eventspace-wait-cursor-count! + e + (sub1 (eventspace-wait-cursor-count e))) + (when (zero? (eventspace-wait-cursor-count e)) + (for ([e (in-list (get-top-level-windows))]) + (send e set-wait-cursor-mode #f)))))) + +(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d4b6cb68..419a303b 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -289,6 +289,9 @@ (define/public (set-status-text s) (void)) (def/public-unimplemented status-line-exists?) + (define/public (set-wait-cursor-mode on?) + (void)) + (define maximized? #f) (define/public (is-maximized?) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index e5305e47..00ccbd0e 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -61,9 +61,6 @@ file-selector is-color-display? get-display-depth - begin-busy-cursor - is-busy? - end-busy-cursor has-x-selection? hide-cursor bell diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 7f48f765..83bda618 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -51,9 +51,6 @@ display-size bell hide-cursor - end-busy-cursor - is-busy? - begin-busy-cursor get-display-depth is-color-display? file-selector @@ -119,11 +116,6 @@ (define-unimplemented bell) (define (hide-cursor) (void)) -(define busy-count 0) -(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count)))) -(define (is-busy?) (positive? busy-count)) -(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count)))) - (define-unimplemented is-color-display?) (define (id-to-menu-item i) i) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index e76fadfd..729f2393 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -39,9 +39,6 @@ file-selector is-color-display? get-display-depth - begin-busy-cursor - is-busy? - end-busy-cursor has-x-selection? hide-cursor bell diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index ba32858c..ba59b565 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -60,9 +60,6 @@ file-selector is-color-display? get-display-depth - begin-busy-cursor - is-busy? - end-busy-cursor has-x-selection? hide-cursor bell diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 2c953a8b..d4d7d4ad 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -42,9 +42,6 @@ display-size bell hide-cursor - end-busy-cursor - is-busy? - begin-busy-cursor get-display-depth is-color-display? file-selector diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 5b507d9e..ea947168 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -56,7 +56,7 @@ (define wx-label-panel% (class wx-horizontal-panel% - (init proxy parent label style font valign) + (init proxy parent label style font halign valign) (inherit area-parent) (define c #f) @@ -67,7 +67,7 @@ (unless (memq 'deleted style) (send (area-parent) add-child this)) (define horiz? (is-horiz? style parent)) - (define p (make-sub horiz? proxy this (if horiz? 'left 'center) valign)) + (define p (make-sub horiz? proxy this (if horiz? 'left halign) valign)) (define l (make-label label proxy p font)) (define/public (set-label s) (when l (send l set-label s))) @@ -96,7 +96,7 @@ (init mred proxy parent cb label x y w h choices style font) (inherit stretchable-in-y stretchable-in-x get-p set-c) - (super-init proxy parent label style font 'center) + (super-init proxy parent label style font 'left 'center) (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices (filter-style style) font)) @@ -154,7 +154,7 @@ (init mred proxy parent cb label kind x y w h choices style font label-font) (inherit get-p set-c) - (super-init proxy parent label style font 'top) + (super-init proxy parent label style font 'left 'top) (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices (filter-style style) font label-font)) @@ -227,7 +227,7 @@ (init mred proxy parent cb label x y w h choices major style font) (inherit stretchable-in-y stretchable-in-x get-p set-c) - (super-init proxy parent label style font 'center) + (super-init proxy parent label style font 'left 'center) (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices major (filter-style style) font)) @@ -302,7 +302,7 @@ (init mred proxy parent label range style font) (inherit stretchable-in-y stretchable-in-x get-p set-c) - (super-init proxy parent label style font 'center) + (super-init proxy parent label style font 'center 'center) (define c (make-object wx-internal-gauge% mred proxy (get-p) label range (filter-style style) font)) @@ -360,7 +360,7 @@ (init mred proxy parent func label value min-val max-val style font) (inherit stretchable-in-y stretchable-in-x get-p set-c) - (super-init proxy parent label style font 'center) + (super-init proxy parent label style font 'center 'center) (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val (filter-style style) font)) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index c54e7c62..0027c1cd 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2069,7 +2069,7 @@ f (lambda (b e) (send f set-cursor (make-object cursor% s))))) - '(arrow bullseye cross hand ibeam watch arrow-watch blank size-n/s size-e/w size-ne/sw size-nw/se)) + '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se)) (send f show #t)) From 7eecbf2f30bb966bf1d229ee0be61d05aee48934 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Aug 2010 12:31:40 -0600 Subject: [PATCH 165/462] gtk cursors original commit: 436eb512f84e8357759278f4f94a50f8e608db81 --- collects/mred/private/wx/cocoa/cursor.rkt | 42 ++-------- .../mred/private/wx/common/cursor-draw.rkt | 61 ++++++++++++++ collects/mred/private/wx/gtk/cursor.rkt | 81 +++++++++++++++++-- collects/mred/private/wx/gtk/frame.rkt | 26 +++++- collects/mred/private/wx/gtk/panel.rkt | 2 + collects/mred/private/wx/gtk/window.rkt | 21 ++++- 6 files changed, 190 insertions(+), 43 deletions(-) create mode 100644 collects/mred/private/wx/common/cursor-draw.rkt diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt index c3235333..7466b995 100644 --- a/collects/mred/private/wx/cocoa/cursor.rkt +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -2,9 +2,9 @@ (require ffi/unsafe ffi/unsafe/objc racket/class - racket/draw "image.rkt" "types.rkt" + "../common/cursor-draw.rkt" "../common/local.rkt") (provide cursor-driver% @@ -26,11 +26,7 @@ id))) (define (make-image-cursor draw-proc) - (let* ([bm (make-object bitmap% 16 16 #f #t)] - [dc (make-object bitmap-dc% bm)]) - (send dc set-smoothing 'aligned) - (draw-proc dc 16 16) - (send dc set-bitmap #f) + (let* ([bm (make-cursor-image draw-proc)]) (let ([image (bitmap->image bm)]) (tell (tell NSCursor alloc) initWithImage: image @@ -38,15 +34,7 @@ (define arrow-cursor-handle (tell NSCursor arrowCursor)) (define (get-wait-cursor-handle) - (image-cursor wait - (lambda (dc w h) - (send dc set-brush "black" 'solid) - (send dc draw-rectangle 5 0 6 4) - (send dc draw-rectangle 5 12 6 4) - (send dc set-brush "white" 'solid) - (send dc draw-ellipse 3 3 10 10) - (send dc draw-line 7 5 7 8) - (send dc draw-line 7 8 9 8)))) + (image-cursor wait draw-watch)) (define cursor-driver% (class object% @@ -67,31 +55,13 @@ [(size-e/w) (set! handle (tell NSCursor resizeLeftRightCursor))] [(size-nw/se) - (set! handle - (image-cursor size-nw/se (lambda (dc w h) - (send dc draw-line 0 16 16 0) - (send dc draw-line 0 0 16 16) - (send dc draw-line 0 3 0 0) - (send dc draw-line 0 0 3 0) - (send dc draw-line 12 15 15 15) - (send dc draw-line 15 15 15 12))))] + (set! handle (image-cursor size-nw/se draw-nw/se))] [(size-ne/sw) - (set! handle - (image-cursor size-ne/sw (lambda (dc w h) - (send dc draw-line 0 16 16 0) - (send dc draw-line 0 0 16 16) - (send dc draw-line 12 0 15 0) - (send dc draw-line 15 0 15 3) - (send dc draw-line 0 12 0 15) - (send dc draw-line 0 15 3 15))))] + (set! handle (image-cursor size-ne/sw draw-ne/sw))] [(watch) (set! handle (get-wait-cursor-handle))] [(bullseye) - (set! handle - (image-cursor bullseye (lambda (dc w h) - (send dc draw-ellipse 1 1 (- w 2) (- h 2)) - (send dc draw-ellipse 4 4 (- w 8) (- h 8)) - (send dc draw-ellipse 7 7 2 2))))] + (set! handle (image-cursor bullseye draw-bullseye))] [(blank) (set! handle (image-cursor blank void))])) diff --git a/collects/mred/private/wx/common/cursor-draw.rkt b/collects/mred/private/wx/common/cursor-draw.rkt new file mode 100644 index 00000000..9eb6d458 --- /dev/null +++ b/collects/mred/private/wx/common/cursor-draw.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require racket/class + racket/draw) + +(provide make-cursor-image + draw-watch + draw-nw/se + draw-ne/sw + draw-bullseye) + +(define (make-cursor-image draw-proc) + (let* ([bm (make-object bitmap% 16 16 #f #t)] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing 'aligned) + (draw-proc dc 16 16) + (send dc set-bitmap #f) + bm)) + +(define (draw-watch dc w h) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 5 0 6 4) + (send dc draw-rectangle 5 12 6 4) + (send dc set-brush "white" 'solid) + (send dc draw-ellipse 3 3 10 10) + (send dc draw-line 7 5 7 8) + (send dc draw-line 7 8 9 8)) + +(define (draw-nw/se dc w h) + (bolden + dc + (lambda () + (send dc set-smoothing 'unsmoothed) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 1 4 1 1) + (send dc draw-line 1 1 4 1) + (send dc draw-line 12 15 15 15) + (send dc draw-line 15 15 15 12)))) + +(define (draw-ne/sw dc w h) + (bolden + dc + (lambda () + (send dc set-smoothing 'unsmoothed) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 12 1 15 1) + (send dc draw-line 15 1 15 4) + (send dc draw-line 1 12 1 15) + (send dc draw-line 1 15 4 15)))) + +(define (draw-bullseye dc w h) + (send dc draw-ellipse 1 1 (- w 2) (- h 2)) + (send dc draw-ellipse 4 4 (- w 8) (- h 8)) + (send dc draw-ellipse 7 7 2 2)) + +(define (bolden dc draw) + (send dc set-pen "white" 4 'solid) + (draw) + (send dc set-pen "black" 2 'solid) + (draw)) diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index 75a30429..c17c8170 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -1,10 +1,81 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "pixbuf.rkt" + "../common/cursor-draw.rkt" "../../syntax.rkt") -(provide cursor-driver%) +(provide cursor-driver% + get-arrow-cursor-handle + get-watch-cursor-handle) + +(define GDK_ARROW 2) ; ugly! +(define GDK_CROSSHAIR 34) +(define GDK_HAND2 60) +(define GDK_SB_H_DOUBLE_ARROW 108) +(define GDK_SB_V_DOUBLE_ARROW 116) +(define GDK_XTERM 152) +(define GDK_TARGET 128) +(define GDK_WATCH 150) + +(define gdk-cursors + (make-hasheq (list + (cons 'arrow GDK_ARROW) + (cons 'cross GDK_CROSSHAIR) + (cons 'ibeam GDK_XTERM) + (cons 'bullseye GDK_TARGET) + (cons 'watch 150) + (cons 'size-e/w GDK_SB_H_DOUBLE_ARROW) + (cons 'size-n/s GDK_SB_V_DOUBLE_ARROW) + (cons 'size-ne/sw draw-ne/sw) + (cons 'size-nw/se draw-nw/se) + (cons 'blank void) + (cons 'hand GDK_HAND2)))) + +(define _GdkCursor (_cpointer 'GdkCursor)) +(define-gdk gdk_cursor_new (_fun _int -> _GdkCursor)) +(define _GdkDisplay (_cpointer 'GdkDisplay)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor)) + +(define (get-arrow-cursor-handle) + (hash-ref gdk-cursors 'arrow #f)) + +(define (get-watch-cursor-handle) + (let ([v (hash-ref gdk-cursors 'watch #f)]) + (if (number? v) + (begin + (send (new cursor-driver%) set-standard 'watch) + (get-watch-cursor-handle)) + v))) (defclass cursor-driver% object% - (def/public-unimplemented ok?) - (define/public (set-standard sym) (void)) + + (define handle #f) + + (define/public (ok?) (and handle #t)) + + (define/public (set-standard sym) + (let ([v (hash-ref gdk-cursors sym #f)]) + (cond + [(not v) (void)] + [(number? v) + (let ([c (gdk_cursor_new v)]) + (hash-set! gdk-cursors sym c) + (set! handle c))] + [(procedure? v) + (let ([bm (make-cursor-image v)]) + (let ([c (gdk_cursor_new_from_pixbuf + (gdk_display_get_default) + (bitmap->pixbuf bm) + 8 + 8)]) + (hash-set! gdk-cursors sym c) + (set! handle c)))] + [else (set! handle v)]))) + + (define/public (get-handle) handle) + (super-new)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 419a303b..24cbd432 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -10,6 +10,7 @@ "client-window.rkt" "widget.rkt" "procs.rkt" + "cursor.rkt" "../common/queue.rkt") (unsafe!) @@ -39,6 +40,8 @@ (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) +(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) + (define-cstruct _GdkGeometry ([min_width _int] [min_height _int] [max_width _int] @@ -289,9 +292,30 @@ (define/public (set-status-text s) (void)) (def/public-unimplemented status-line-exists?) + (define waiting-cursor? #f) (define/public (set-wait-cursor-mode on?) - (void)) + (set! waiting-cursor? on?) + (send in-window enter-window)) + (define current-cursor-handle #f) + (define in-window #f) + (define/override (set-parent-window-cursor in-win c) + (set! in-window in-win) + (let ([c (if waiting-cursor? + (get-watch-cursor-handle) + c)]) + (unless (eq? c current-cursor-handle) + (atomically + (set! current-cursor-handle c) + (gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle)) + #f + c)))))) + (define/override (enter-window) (void)) + (define/override (leave-window) (void)) + + (define/override (check-window-cursor win) + (send in-window enter-window)) + (define maximized? #f) (define/public (is-maximized?) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 54ccd948..52f75d89 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -62,6 +62,8 @@ (define gtk (get-gtk)) + (connect-key-and-mouse gtk) + (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move gtk child-gtk x y) (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 85ab4897..07b0e93d 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -7,6 +7,7 @@ "../common/event.rkt" "../common/freeze.rkt" "../common/queue.rkt" + "../common/local.rkt" "keycode.rkt" "queue.rkt" "utils.rkt" @@ -160,11 +161,13 @@ (define-signal-handler connect-enter "enter-notify-event" (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) (when wx (send wx enter-window))) (do-button-event gtk event #f #t))) (define-signal-handler connect-leave "leave-notify-event" (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) (do-button-event gtk event #f #t))) (define (connect-key-and-mouse gtk [skip-press? #f]) @@ -441,8 +444,24 @@ (define/public (set-focus) (gtk_widget_grab_focus (get-client-gtk))) + (define cursor-handle #f) (define/public (set-cursor v) - (void)) + (set! cursor-handle (and v + (send (send v get-driver) get-handle))) + (check-window-cursor this)) + (define/public (enter-window) + (set-window-cursor this #f)) + (define/public (leave-window) + (when parent + (send parent enter-window))) + (define/public (set-window-cursor in-win c) + (set-parent-window-cursor in-win (or c cursor-handle))) + (define/public (set-parent-window-cursor in-win c) + (when parent + (send parent set-window-cursor in-win c))) + (define/public (check-window-cursor win) + (when parent + (send parent check-window-cursor win))) (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) From 33d4417d45b3a1d41a511e981fd482508df4dac9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Aug 2010 09:12:28 -0600 Subject: [PATCH 166/462] fix problem related to cursor tracking original commit: b3f1cc4b41ddde52f6ee898028aa3d9989d22ea2 --- collects/mred/private/wx/gtk/frame.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 24cbd432..005dad55 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -295,7 +295,8 @@ (define waiting-cursor? #f) (define/public (set-wait-cursor-mode on?) (set! waiting-cursor? on?) - (send in-window enter-window)) + (when in-window + (send in-window enter-window))) (define current-cursor-handle #f) (define in-window #f) @@ -314,7 +315,8 @@ (define/override (leave-window) (void)) (define/override (check-window-cursor win) - (send in-window enter-window)) + (when in-window + (send in-window enter-window))) (define maximized? #f) From e9bea2c193c8bd6e7304f50e15f1f06bc13ca300 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Sep 2010 07:23:25 -0600 Subject: [PATCH 167/462] cocoa tab-panel in no-border mode uses PSMTabBarControl original commit: 15a7a2a006b3ee501b098a801a6b8bd26f439b24 --- collects/mred/private/mrpanel.rkt | 8 +- collects/mred/private/wx/cocoa/canvas.rkt | 4 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 83 ++++++++++++++++---- collects/mred/private/wx/cocoa/utils.rkt | 3 +- collects/mred/private/wx/cocoa/window.rkt | 31 +++++++- 5 files changed, 102 insertions(+), 27 deletions(-) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 4c42d08c..b06dc927 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -131,9 +131,11 @@ (check-container-parent cwho parent) (check-style cwho #f '(deleted no-border) style) (check-font cwho font)) - (super-init parent (if (memq 'deleted style) - '(deleted) - null)) + (super-init parent (if (memq 'no-border style) + (if (eq? (car style) 'no-border) + (cdr style) + (list (car style))) + (cons 'border style))) (send (mred->wx this) set-callback callback)) (public diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 9e7dff5d..19d2d4d2 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -47,7 +47,7 @@ (tellv ctx restoreGraphicsState))))))) (define-objc-class MyView NSView - #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) [wxb] (-a _void (drawRect: [_NSRect r]) (when wxb @@ -127,7 +127,7 @@ (tellv ctx restoreGraphicsState))))) (define-objc-class MyComboBox NSComboBox - #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) #:protocols (NSComboBoxDelegate) [wxb] (-a _void (drawRect: [_NSRect r]) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 58beb5f6..4662c0d4 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -14,7 +14,11 @@ (provide tab-panel%) -(import-class NSView NSTabView NSTabViewItem) +;; Load PSMTabBarControl: +(void (ffi-lib "PSMTabBarControl.framework/PSMTabBarControl")) +(define NSNoTabsNoBorder 6) + +(import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) (define-objc-class MyTabView NSTabView @@ -24,6 +28,13 @@ (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) +(define-objc-class MyPSMTabBarControl PSMTabBarControl + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) + (super-tell #:type _void tabView: cocoa didSelectTabViewItem: item-cocoa) + (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) + (defclass tab-panel% (panel-mixin window%) (init parent x y w h @@ -31,38 +42,73 @@ labels) (inherit get-cocoa) - (define cocoa (as-objc-allocation - (tell (tell MyTabView alloc) init))) + (define tabv-cocoa (as-objc-allocation + (tell (tell MyTabView alloc) init))) + (define cocoa (if (not (memq 'border style)) + (tell (tell NSView alloc) init) + tabv-cocoa)) + + (define control-cocoa + (and (not (memq 'border style)) + (let ([i (as-objc-allocation + (tell (tell MyPSMTabBarControl alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize 200 22))))]) + (tellv cocoa addSubview: i) + (tellv cocoa addSubview: tabv-cocoa) + (tellv tabv-cocoa setDelegate: i) + (tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder) + (tellv i setTabView: tabv-cocoa) + (tellv i setStyleNamed: #:type _NSString "Aqua") + ;;(tellv i setSizeCellsToFit: #:type _BOOL #t) + (tellv i setDisableTabClose: #:type _BOOL #t) + i))) + (define item-cocoas (for/list ([lbl (in-list labels)]) (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) - (tellv cocoa addTabViewItem: item) + (tellv tabv-cocoa addTabViewItem: item) item))) - (let ([sz (tell #:type _NSSize cocoa minimumSize)]) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz))) - (tellv cocoa setDelegate: cocoa) + (if control-cocoa + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize 50 22))) + (let ([sz (tell #:type _NSSize tabv-cocoa minimumSize)]) + (tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz)) + (tellv tabv-cocoa setDelegate: tabv-cocoa))) (define content-cocoa (as-objc-allocation (tell (tell NSView alloc) - initWithFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect)))) - (tell #:type _void cocoa addSubview: content-cocoa) + initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))) + (tellv tabv-cocoa addSubview: content-cocoa) (define/override (get-cocoa-content) content-cocoa) - (define/override (get-cocoa-cursor-content) cocoa) + (define/override (get-cocoa-cursor-content) tabv-cocoa) (define/override (set-size x y w h) (super set-size x y w h) - (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect))) + (when control-cocoa + (let ([r (tell #:type _NSRect cocoa frame)]) + (tellv control-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint + 0 + (- (NSSize-height (NSRect-size r)) 22)) + (make-NSSize + (NSSize-width (NSRect-size r)) + 22))) + (tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize + (NSSize-width (NSRect-size r)) + (- (NSSize-height (NSRect-size r)) 22)))))) + (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect))) (define/public (set-label i str) (tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str))) (define/public (set-selection i) - (tellv cocoa selectTabViewItem: (list-ref item-cocoas i))) + (tellv tabv-cocoa selectTabViewItem: (list-ref item-cocoas i))) (define/public (get-selection) - (item->index (tell cocoa selectedTabViewItem))) + (item->index (tell tabv-cocoa selectedTabViewItem))) (define (item->index tv) (for/or ([c (in-list item-cocoas)] @@ -74,17 +120,17 @@ (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) - (tellv cocoa addTabViewItem: item) + (tellv tabv-cocoa addTabViewItem: item) (set! item-cocoas (append item-cocoas (list item))))) (define/public (delete i) (let ([item-cocoa (list-ref item-cocoas i)]) - (tellv cocoa removeTabViewItem: item-cocoa) + (tellv tabv-cocoa removeTabViewItem: item-cocoa) (set! item-cocoas (remq item-cocoa item-cocoas)))) (define/public (set choices) (for ([item-cocoa (in-list item-cocoas)]) - (tellv cocoa removeTabViewItem: item-cocoa)) + (tellv tabv-cocoa removeTabViewItem: item-cocoa)) (set! item-cocoas null) (for ([lbl (in-list choices)]) (append* lbl))) @@ -98,4 +144,7 @@ (super-new [parent parent] [cocoa cocoa] - [no-show? (memq 'deleted style)])) + [no-show? (memq 'deleted style)]) + + (when control-cocoa + (set-ivar! control-cocoa wxb (->wxb this)))) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index a4486769..f57c7c48 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -58,4 +58,5 @@ (make-weak-box wx)) (define (->wx wxb) - (weak-box-value wxb)) + (and wxb + (weak-box-value wxb))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 70caeb77..ab2e8f99 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -22,6 +22,7 @@ FocusResponder KeyMouseResponder + KeyMouseTextResponder CursorDisplayer queue-window-event @@ -49,6 +50,9 @@ (when wx (send wx is-responder wx #f)) #t))]) +(import-class NSArray) +(import-protocol NSTextInput) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -106,9 +110,20 @@ (super-tell #:type _void keyDown: event))] [-a _void (insertText: [_NSString str]) (let ([wx (->wx wxb)]) + (post-dummy-event) ;; to wake up in case of character palette insert (when wx (queue-window-event wx (lambda () - (send wx key-event-as-string str)))))]) + (send wx key-event-as-string str)))))] + + ;; for NSTextInput, to enable character palette insert: + [-a _BOOL (hasMarkedText) #f] + [-a _id (validAttributesForMarkedText) + (tell NSArray array)]) + +(define-objc-mixin (KeyMouseTextResponder Superclass) + #:mixins (KeyMouseResponder) + #:protocols (NSTextInput) + [wxb]) (define-objc-mixin (CursorDisplayer Superclass) [wxb] @@ -124,16 +139,24 @@ (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)]) + [str (tell #:type _NSString event characters)] + [control? (bit? modifiers NSControlKeyMask)]) (let-values ([(x y) (send wx window-point-to-view pos)]) (let ([k (new key-event% [key-code (or (map-key-code (tell #:type _ushort event keyCode)) (if (string=? "" str) #\nul - (string-ref str 0)))] + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1a) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0)))) + c))))] [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] + [control-down control?] [meta-down (bit? modifiers NSCommandKeyMask)] [alt-down (bit? modifiers NSAlternateKeyMask)] [x (->long x)] From d6f2a2e62dfdfa24be47d66807cf37a5c58e38b2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Sep 2010 07:38:14 -0600 Subject: [PATCH 168/462] another refinement to cocoa key handling original commit: cc737fc571bff9b4e38038554c6d22ce256e1e2a --- collects/mred/private/wx/cocoa/window.rkt | 130 +++++++++++++--------- 1 file changed, 80 insertions(+), 50 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ab2e8f99..b1e703b5 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -53,6 +53,8 @@ (import-class NSArray) (import-protocol NSTextInput) +(define current-insert-text (make-parameter #f)) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -106,19 +108,34 @@ (super-tell #:type _void otherMouseDragged: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event) + (unless (do-key-event wxb event self) (super-tell #:type _void keyDown: event))] [-a _void (insertText: [_NSString str]) - (let ([wx (->wx wxb)]) - (post-dummy-event) ;; to wake up in case of character palette insert - (when wx - (queue-window-event wx (lambda () - (send wx key-event-as-string str)))))] + (let ([cit (current-insert-text)]) + (if cit + (set-box! cit str) + (let ([wx (->wx wxb)]) + (post-dummy-event) ;; to wake up in case of character palette insert + (when wx + (queue-window-event wx (lambda () + (send wx key-event-as-string str)))))))] - ;; for NSTextInput, to enable character palette insert: + ;; for NSTextInput: [-a _BOOL (hasMarkedText) #f] [-a _id (validAttributesForMarkedText) - (tell NSArray array)]) + (tell NSArray array)] + [-a _void (unmarkText) (void)] + [-a _NSRange (markedRange) (make-NSRange 0 0)] + [-a _NSRange (selectedRange) (make-NSRange 0 0)] + [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + (void)] + [-a _id (validAttributesForMarkedText) #f] + [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] + [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] + [-a _NSInteger (conversationIdentifier) 0] + [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] + [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) + (make-NSSize 0 0))]) (define-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -132,51 +149,64 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event) +(define (do-key-event wxb event self) (let ([wx (->wx wxb)]) (and wx - (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] - [bit? (lambda (m b) (positive? (bitwise-and m b)))] - [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)] - [control? (bit? modifiers NSControlKeyMask)]) - (let-values ([(x y) (send wx window-point-to-view pos)]) - (let ([k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1a) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c))))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down control?] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [x (->long x)] - [y (->long y)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (if (send wx definitely-wants-event? k) - (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)))))))) + (let ([inserted-text (box #f)]) + ;; Calling `interpretKeyEvents:' allows key combinations to be + ;; handled, such as option-e followed by e to produce é. The + ;; call to `interpretKeyEvents:' typically calls `insertText:', + ;; so we set `current-insert-text' to tell `insertText:' to just + ;; give us back the text in the parameter. For now, we ignore the + ;; text and handle the event as usual, though probably we should + ;; be doing something with it. + (parameterize ([current-insert-text inserted-text]) + (tellv self interpretKeyEvents: (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1))) + + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)] + [str (tell #:type _NSString event characters)] + [control? (bit? modifiers NSControlKeyMask)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1a) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0)))) + c))))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down control?] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (if (send wx definitely-wants-event? k) + (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 (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) (let ([wx (->wx wxb)]) From b595eec7503875cf859e8fcf8bddb161863bbabe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Sep 2010 08:12:25 -0600 Subject: [PATCH 169/462] repairs that make dragable panels work original commit: e153b71ba0759383b26a1f128ca42e40959cf794 --- collects/mred/private/wx/cocoa/cursor.rkt | 14 ++++++++++ collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/common/cursor.rkt | 9 +++++++ collects/mred/private/wx/common/event.rkt | 3 +-- collects/mred/private/wx/gtk/cursor.rkt | 14 ++++++++++ collects/mred/private/wx/gtk/panel.rkt | 31 ++++++++++++++++------ 6 files changed, 62 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt index 7466b995..28fc4e5d 100644 --- a/collects/mred/private/wx/cocoa/cursor.rkt +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -2,8 +2,10 @@ (require ffi/unsafe ffi/unsafe/objc racket/class + racket/draw "image.rkt" "types.rkt" + "utils.rkt" "../common/cursor-draw.rkt" "../common/local.rkt") @@ -64,6 +66,18 @@ (set! handle (image-cursor bullseye draw-bullseye))] [(blank) (set! handle (image-cursor blank void))])) + + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([image (bitmap->image bm)]) + (set! handle + (as-objc-allocation + (tell (tell NSCursor alloc) + initWithImage: image + hotSpot: #:type _NSPoint (make-NSPoint hot-spot-x hot-spot-y))))))) (define/public (ok?) (and handle #t)) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index ec461c46..1ef4c77e 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -15,7 +15,7 @@ (import-class NSView) (define-objc-class MyPanelView NSView - #:mixins (CursorDisplayer) + #:mixins (KeyMouseTextResponder CursorDisplayer) [wxb]) (define (panel-mixin %) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt index fb879edf..f8aa09ac 100644 --- a/collects/mred/private/wx/common/cursor.rkt +++ b/collects/mred/private/wx/common/cursor.rkt @@ -9,6 +9,11 @@ (define standards (make-hash)) +(define (is-16x16? image) + (and (not (send image is-color?)) + (= 16 (send image get-width)) + (= 16 (send image get-height)))) + (defclass cursor% object% (init-rest args) @@ -28,6 +33,10 @@ [bitmap% mask] [(integer-in 0 15) [hot-spot-x 0]] [(integer-in 0 15) [hot-spot-y 0]]) + (unless (is-16x16? image) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| image)) + (unless (is-16x16? mask) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| mask)) (let ([c (new cursor-driver%)]) (send c set-image image mask hot-spot-x hot-spot-y) c)] diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index acfcf085..1c757d79 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -67,8 +67,7 @@ (eq? et 'leave)) (def/public (moving?) - (and (eq? et 'motion) - (not (or left-down middle-down right-down))))) + (eq? et 'motion))) (defclass key-event% event% (init-properties [[(make-alts symbol? char?) key-code] #\nul] diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index c17c8170..fb6d7420 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class + racket/draw "utils.rkt" "types.rkt" "pixbuf.rkt" @@ -76,6 +77,19 @@ (set! handle c)))] [else (set! handle v)]))) + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([pixbuf (bitmap->pixbuf bm)]) + (set! handle + (gdk_cursor_new_from_pixbuf + (gdk_display_get_default) + pixbuf + hot-spot-x + hot-spot-y))))) + (define/public (get-handle) handle) (super-new)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 52f75d89..767db962 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -1,17 +1,18 @@ #lang scheme/base (require scheme/class - scheme/foreign + ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "window.rkt" "utils.rkt" - "types.rkt") -(unsafe!) + "types.rkt" + "const.rkt") (provide panel% panel-mixin) -; (define-gtk gtk_alignment_new (_fun _gfloat _gfloat _gfloat _gfloat -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) +(define-gtk gtk_event_box_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) @@ -56,14 +57,28 @@ (inherit set-size get-gtk) + (define gtk (as-gtk-allocation (gtk_event_box_new))) + (define client-gtk (atomically + (let ([client (gtk_fixed_new)]) + (gtk_container_add gtk client) + (gtk_widget_show client) + client))) + + (define/override (get-client-gtk) client-gtk) + (super-new [parent parent] - [gtk (as-gtk-allocation (gtk_fixed_new))] + [gtk gtk] + [extra-gtks (list client-gtk)] [no-show? (memq 'deleted style)]) - (define gtk (get-gtk)) - (connect-key-and-mouse gtk) + (gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) (define/override (set-child-size child-gtk x y w h) - (gtk_fixed_move gtk child-gtk x y) + (gtk_fixed_move client-gtk child-gtk x y) (gtk_widget_set_size_request child-gtk w h)))) From 4e92ae39afe677307e4ff4b92e4a2a4d6d4599ae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Sep 2010 08:45:19 -0600 Subject: [PATCH 170/462] show gtk menu shortcuts original commit: f21920c8e92732ccea5366d2dda7123bd1d0493c --- collects/mred/private/wx/gtk/frame.rkt | 2 ++ collects/mred/private/wx/gtk/menu-bar.rkt | 2 ++ collects/mred/private/wx/gtk/menu.rkt | 4 +++- collects/mred/private/wx/gtk/window.rkt | 13 ++++++++++++- 4 files changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 005dad55..a1054c74 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -139,6 +139,8 @@ (when label (gtk_window_set_title gtk label)) + ;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group) + (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move panel-gtk child-gtk x y) (gtk_widget_set_size_request child-gtk w h)) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 8a752538..183d99ae 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -82,6 +82,8 @@ (connect-menu-key-press gtk) (connect-menu-button-press gtk) + ; (gtk_menu_set_accel_group gtk the-accelerator-group) + (define top-wx #f) (define/public (set-top-window top) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 4d145ec9..504d8d92 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -88,6 +88,8 @@ (connect-menu-deactivate gtk) + (gtk_menu_set_accel_group gtk the-accelerator-group) + (define items null) (define parent #f) @@ -168,7 +170,7 @@ (char->integer (string-ref (cadr m) 0)))]) (unless (zero? code) - (let ([accel-path (format "/Thing/~a" title)]) + (let ([accel-path (format "/Hardwired/~a" title)]) (gtk_accel_map_add_entry accel-path code GDK_CONTROL_MASK) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 07b0e93d..65f881b2 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -36,7 +36,11 @@ (struct-out GtkRequisition) _GtkRequisition-pointer (struct-out GtkAllocation) _GtkAllocation-pointer - widget-window) + widget-window + + the-accelerator-group + gtk_window_add_accel_group + gtk_menu_set_accel_group) ;; ---------------------------------------- @@ -62,6 +66,13 @@ (define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) +(define _GtkAccelGroup (_cpointer 'GtkAccelGroup)) +(define-gtk gtk_accel_group_new (_fun -> _GtkAccelGroup)) +(define-gtk gtk_window_add_accel_group (_fun _GtkWindow _GtkAccelGroup -> _void)) +(define-gtk gtk_menu_set_accel_group (_fun _GtkWidget _GtkAccelGroup -> _void)) + +(define the-accelerator-group (gtk_accel_group_new)) + (define-cstruct _GtkWidgetT ([obj _GtkObject] [private_flags _uint16] [state _byte] From f60b9e42c451c0021d1454c326ae7350c6eff943 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 5 Sep 2010 07:22:59 -0600 Subject: [PATCH 171/462] [PATCH 123/326] bell original commit: 074ba4e70e0cf68cdfd74187154e849deb72424a --- collects/mred/private/wx/cocoa/procs.rkt | 7 +++++-- collects/mred/private/wx/cocoa/utils.rkt | 3 +++ collects/mred/private/wx/gtk/procs.rkt | 4 +++- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 2b4cc3db..ecf789e1 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -4,6 +4,7 @@ racket/draw ffi/unsafe ffi/unsafe/objc + "utils.rkt" "types.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -105,8 +106,10 @@ (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) (set-box! xb (->long (NSSize-width (NSRect-size f)))) (set-box! yb (->long (NSSize-height (NSRect-size f)))))) - -(define (bell) (void)) + +(define-appkit NSBeep (_fun -> _void)) +(define (bell) (NSBeep)) + (define (hide-cursor) (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index f57c7c48..37c1712c 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -10,6 +10,7 @@ define-cocoa define-cf define-appserv + define-appkit define-mz as-objc-allocation retain release @@ -21,10 +22,12 @@ (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) (define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) +(define appkit-lib (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))) (define-ffi-definer define-cocoa cocoa-lib) (define-ffi-definer define-cf cf-lib) (define-ffi-definer define-appserv appserv-lib) +(define-ffi-definer define-appkit appkit-lib) (define (objc-delete v) (tellv v release)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 83bda618..229e4d2a 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -113,7 +113,9 @@ (set-box! h (gdk_screen_get_height s)))) (define (get-display-depth) 32) -(define-unimplemented bell) +(define-gdk gdk_display_beep (_fun _GdkDisplay -> _void)) +(define (bell) (gdk_display_beep (gdk_display_get_default))) + (define (hide-cursor) (void)) (define-unimplemented is-color-display?) From 2567832c8518d5a0d7710b9142c62bae38a104fc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 5 Sep 2010 09:00:34 -0600 Subject: [PATCH 172/462] gtk alternate key interpretetaions original commit: 1270ba437eec0c02ad3f372f4c3ff35b17fb9e95 --- collects/mred/private/wx/gtk/keymap.rkt | 42 +++++++++++++++++++++++++ collects/mred/private/wx/gtk/window.rkt | 15 ++++++--- 2 files changed, 53 insertions(+), 4 deletions(-) create mode 100644 collects/mred/private/wx/gtk/keymap.rkt diff --git a/collects/mred/private/wx/gtk/keymap.rkt b/collects/mred/private/wx/gtk/keymap.rkt new file mode 100644 index 00000000..fc827e06 --- /dev/null +++ b/collects/mred/private/wx/gtk/keymap.rkt @@ -0,0 +1,42 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "const.rkt" + "types.rkt") + +(provide get-alts) + +(define _GdkKeymap (_cpointer 'GdkKeymap)) + +(define-gdk gdk_keymap_get_default (_fun -> _GdkKeymap)) + +(define-gdk gdk_keymap_translate_keyboard_state + (_fun _GdkKeymap + _uint ; hardware_keycode + _int ; GdkModifierType state + _int ; group + (keyval : (_ptr o _uint)) + (effective_group : (_ptr o _int)) + (level : (_ptr o _int)) + (consumed_modifiers : (_ptr o _int)) + -> (r : _gboolean) + -> (and r keyval))) + +(define (get-alts event) + (define (get-one-alt mask) + (gdk_keymap_translate_keyboard_state (gdk_keymap_get_default) + (GdkEventKey-hardware_keycode event) + (let ([mods (GdkEventKey-state event)]) + (bitwise-ior (- mods (bitwise-and mods mask)) + (bitwise-and mask (bitwise-not (bitwise-and mods mask))))) + (GdkEventKey-group event))) + (let ([alt-gr? (eq? (= (bitwise-and (GdkEventKey-state event) GDK_CONTROL_MASK) + GDK_CONTROL_MASK) + (= (bitwise-and (GdkEventKey-state event) GDK_MOD1_MASK) + GDK_MOD1_MASK))]) + (values (get-one-alt GDK_SHIFT_MASK) + (and alt-gr? + (get-one-alt (bitwise-ior GDK_MOD1_MASK GDK_CONTROL_MASK))) + (and alt-gr? + (get-one-alt (bitwise-ior GDK_SHIFT_MASK GDK_MOD1_MASK GDK_CONTROL_MASK))) + (get-one-alt GDK_LOCK_MASK)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 65f881b2..c843f68a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -9,6 +9,7 @@ "../common/queue.rkt" "../common/local.rkt" "keycode.rkt" + "keymap.rkt" "queue.rkt" "utils.rkt" "const.rkt" @@ -128,11 +129,12 @@ wx (let* ([modifiers (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))))] [k (new key-event% - [key-code (let ([kv (GdkEventKey-keyval event)]) - (or - (map-key-code kv) - (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (keyval->code (GdkEventKey-keyval event))] [shift-down (bit? modifiers GDK_SHIFT_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)] [meta-down (bit? modifiers GDK_META_MASK)] @@ -141,6 +143,11 @@ [y 0] [time-stamp (GdkEventKey-time event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (let-values ([(s ag sag cl) (get-alts event)]) + (when s (send k set-other-shift-key-code (keyval->code s))) + (when ag (send k set-other-altgr-key-code (keyval->code ag))) + (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) + (when cl (send k set-other-caps-key-code (keyval->code cl)))) (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) From 7213e034c3b3bba2641480b9085f3e95874305d9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 5 Sep 2010 09:29:57 -0600 Subject: [PATCH 173/462] showkey as module original commit: a7a629e45b602d02e258940f6bc5ed7cc7108df7 --- collects/tests/gracket/showkey.rkt | 77 ++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 collects/tests/gracket/showkey.rkt diff --git a/collects/tests/gracket/showkey.rkt b/collects/tests/gracket/showkey.rkt new file mode 100644 index 00000000..64de9155 --- /dev/null +++ b/collects/tests/gracket/showkey.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/gui/base + racket/class) + +(let () + (define iter 0) + (define c% + (class canvas% + (super-new) + (define/override (on-event ev) + (lambda (ev) + (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" + (es-check) + iter + (send ev get-event-type) + (send ev get-x) + (send ev get-y) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" "") + (if (send ev get-left-down) " LEFT" "") + (if (send ev get-middle-down) " MIDDLE" "") + (if (send ev get-right-down) " RIGHT" "") + (if (send ev dragging?) + " dragging" + "") + (if (send ev moving?) + " moving" + "") + (if (send ev entering?) + " entering" + "") + (if (send ev leaving?) + " leaving" + "")))) + (define/override (on-char ev) + (set! iter (add1 iter)) + (printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n" + (es-check) + iter + (let ([v (send ev get-key-code)]) + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v)))) + (let ([v (send ev get-key-release-code)]) + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v)))) + (let ([vs (list (send ev get-other-shift-key-code) + (send ev get-other-altgr-key-code) + (send ev get-other-shift-altgr-key-code) + (send ev get-other-caps-key-code))]) + (map (lambda (v) + (and v + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v))))) + vs)) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" ""))))) + (define f (make-object (class frame% + (inherit accept-drop-files) + (define/override (on-drop-file file) + (printf "Dropped: ~a\n" file)) + (super-make-object "tests" #f 100 100) + (accept-drop-files #t)))) + (define c (make-object c% f)) + (define (es-check) (if (eq? (send f get-eventspace) (current-eventspace)) + "" + ">>WRONG EVENTSPACE<<\n")) + (send c focus) + (send f show #t)) From f7caa3965bf383bbc2ec5cccdb28d0a34d6372e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 06:51:21 -0600 Subject: [PATCH 174/462] fix problems with gtk canvas client size and with checkable menus original commit: 6772afbd2eca2c2e145cd81e9d3dadaa6c1412f7 --- collects/mred/private/wx/gtk/canvas.rkt | 63 ++++++++++++------- .../mred/private/wx/gtk/client-window.rkt | 16 ----- collects/mred/private/wx/gtk/menu.rkt | 38 ++++++----- collects/mred/private/wx/gtk/window.rkt | 12 ---- 4 files changed, 63 insertions(+), 66 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index dd256a66..c96d3144 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -185,7 +185,8 @@ (inherit get-gtk set-size get-size get-client-size on-size get-top-win - set-auto-size adjust-client-delta) + set-auto-size + adjust-client-delta infer-client-delta) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -199,7 +200,8 @@ (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box - combo-button-gtk) + combo-button-gtk + scroll-width) (atomically ;; need to connect all children to gtk to avoid leaks (cond [(or (memq 'hscroll style) @@ -214,6 +216,13 @@ [hscroll (gtk_hscrollbar_new hadj)] [vscroll (gtk_vscrollbar_new vadj)] [resize-box (gtk_drawing_area_new)]) + ;; |------------------------------------| + ;; | h |-----------------| |-----------|| + ;; | | v | | v2 || + ;; | | | | [vscroll] || + ;; | | [h2 [hscroll]] | | [resize] || + ;; | |-----------------| |-----------|| + ;; |------------------------------------| (when has-border? (gtk_container_set_border_width h margin)) (gtk_box_pack_start h v #t #t 0) @@ -223,28 +232,29 @@ (gtk_box_pack_start v h2 #f #f 0) (gtk_box_pack_start h2 hscroll #t #t 0) (gtk_box_pack_start v2 resize-box #f #f 0) - (gtk_widget_show hscroll) + (when (memq 'hscroll style) + (gtk_widget_show hscroll)) (gtk_widget_show vscroll) (gtk_widget_show h) (gtk_widget_show v) - (gtk_widget_show v2) + (when (memq 'vscroll style) + (gtk_widget_show v2)) (gtk_widget_show h2) - (gtk_widget_show resize-box) + (when (memq 'hscroll style) + (gtk_widget_show resize-box)) (gtk_widget_show client-gtk) - (unless (memq 'hscroll style) - (gtk_widget_hide hscroll) - (gtk_widget_hide resize-box)) - (unless (memq 'vscroll style) - (gtk_widget_hide v2)) - (values client-gtk h hadj vadj - (and (memq 'hscroll style) h2) - (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box) - #f)))] + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request vscroll req) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f + (GtkRequisition-width req)))))] [is-combo? (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] [has-border? (let ([client-gtk (gtk_drawing_area_new)] [h (as-gtk-allocation (gtk_hbox_new #f 0))]) @@ -252,10 +262,10 @@ (gtk_container_set_border_width h margin) (connect-expose-border h) (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f #f))] + (values client-gtk h #f #f #f #f #f #f 0))] [else (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) - (values client-gtk client-gtk #f #f #f #f #f #f))]))) + (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) (super-new [parent parent] [gtk gtk] @@ -268,9 +278,9 @@ (if combo-button-gtk (list client-gtk combo-button-gtk) (list client-gtk))))]) - - (set-size x y w h) + (set-size x y w h) + (define dc (new dc% [canvas this])) (gtk_widget_realize gtk) @@ -303,7 +313,14 @@ (when vscroll-adj (connect-value-changed-v vscroll-adj)) (set-auto-size) - (adjust-client-delta margin margin) + (adjust-client-delta (+ (* 2 margin) + (if (memq 'vscroll style) + scroll-width + 0)) + (+ (* 2 margin) + (if (memq 'hscroll style) + scroll-width + 0))) (define/override (direct-update?) #f) @@ -400,7 +417,9 @@ (gtk_widget_show resize-box)] [(and v? (not h?)) ;; remove corner - (gtk_widget_hide resize-box)]))) + (gtk_widget_hide resize-box)])) + (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) + (+ (* 2 margin) (if h? scroll-width 0)))) (define/private (configure-adj adj scroll-gtk len page pos) (when (and scroll-gtk adj) diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 5c34d43c..ed86c963 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -29,12 +29,8 @@ (class % (init client-gtk) - (inherit remember-client-size) - (connect-size-allocate client-gtk) - (define client-w 0) - (define client-h 0) (define client-x 0) (define client-y 0) @@ -44,9 +40,6 @@ ;; Called in the Gtk event-loop thread (set! client-x x) (set! client-y y) - (set! client-w w) - (set! client-h h) - (remember-client-size w h) (queue-window-event this (lambda () (internal-on-client-size w h) (on-client-size w h)))) @@ -54,15 +47,6 @@ (define/public (internal-on-client-size w h) (void)) - (define/override (tentative-client-size w h) - (set! client-w w) - (set! client-h h)) - - #; - (define/override (get-client-size xb yb) - (set-box! xb client-w) - (set-box! yb client-h)) - (define/override (get-client-delta) (values client-x client-y)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 504d8d92..9cb4a3a5 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -129,23 +129,26 @@ 0 (gtk_get_current_event_time))) + (define ignore-callback? #f) + (define/public (do-selected menu-item) ;; Called in event-pump thread - (let ([top (get-top-parent)]) - (cond - [top - (queue-window-event - top - (lambda () (send top on-menu-command menu-item)))] - [on-popup - (let* ([e (new popup-event% [event-type 'menu-popdown])] - [pu on-popup] - [cnb cancel-none-box]) - (set! on-popup #f) - (set-box! cancel-none-box #t) - (send e set-menu-id menu-item) - (pu (lambda () (cb this e))))] - [parent (send parent do-selected menu-item)]))) + (unless ignore-callback? + (let ([top (get-top-parent)]) + (cond + [top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))] + [on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (set! on-popup #f) + (set-box! cancel-none-box #t) + (send e set-menu-id menu-item) + (pu (lambda () (cb this e))))] + [parent (send parent do-selected menu-item)])))) (define/public (do-no-selected) ;; Queue a none-selected event, but only tentatively, because @@ -237,7 +240,10 @@ (define/public (check item on?) (let ([gtk (find-gtk item)]) (when gtk - (gtk_check_menu_item_set_active gtk on?)))) + (atomically + (set! ignore-callback? #t) + (gtk_check_menu_item_set_active gtk on?) + (set! ignore-callback? #f))))) (define/public (checked? item) (let ([gtk (find-gtk item)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index c843f68a..321eb1bb 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -338,8 +338,6 @@ (unless (= h -1) (set! save-h h)) (set! save-w (max save-w client-delta-w)) (set! save-h (max save-h client-delta-h)) - (tentative-client-size (+ save-w client-delta-w) - (+ save-h client-delta-h)) (really-set-size gtk save-x save-y save-w save-h))) (define/public (save-size x y w h) @@ -368,16 +366,6 @@ (define client-delta-w 0) (define client-delta-h 0) - (define min-client-delta-w 0) - (define min-client-delta-h 0) - (define/public (remember-client-size w h) - ;; Called in the Gtk event-loop thread - ;(set! client-delta-w (max min-client-delta-w (- save-w w))) - ;(set! client-delta-h (max min-client-delta-h (- save-h h))) - #;(queue-window-event this (lambda () (on-size 0 0))) - (void)) - (define/public (tentative-client-size w h) - (void)) (define/public (adjust-client-delta dw dh) (set! client-delta-w dw) From 96310b96ca261e71b073cc6568e2c8b1176999bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 07:33:14 -0600 Subject: [PATCH 175/462] fix gtk win32 poll original commit: 93613f906d9ae630e3e8a18242e8c224a53f6273 --- collects/mred/private/wx/gtk/queue.rkt | 30 +++++++++++++++--------- collects/mred/private/wx/gtk/w32.rkt | 32 ++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 11 deletions(-) create mode 100644 collects/mred/private/wx/gtk/w32.rkt diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index bc6d8c35..8abda62e 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -6,7 +6,8 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" - "const.rkt") + "const.rkt" + "w32.rkt") (provide gtk-start-event-pump @@ -63,6 +64,8 @@ (define-mz scheme_get_fdset (_fun _pointer _int -> _pointer)) (define-mz scheme_fdset (_fun _pointer _int -> _void)) (define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void)) +(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void) + #:fail #f) (define (install-wakeup fds) (pre-event-sync #t) @@ -79,16 +82,21 @@ (set! poll-fds (malloc _GPollFD n)) (set! poll-fd-count n) (install-wakeup fds)) - (for ([i (in-range n)]) - (let* ([gfd (ptr-ref poll-fds _GPollFD i)] - [fd (GPollFD-fd gfd)] - [events (GPollFD-events gfd)]) - (when (not (zero? (bitwise-and events POLLIN))) - (scheme_fdset (scheme_get_fdset fds 0) fd)) - (when (not (zero? (bitwise-and events POLLOUT))) - (scheme_fdset (scheme_get_fdset fds 1) fd)) - (when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP)))) - (scheme_fdset (scheme_get_fdset fds 2) fd))))))) + (if (eq? 'windows (system-type)) + ;; We don't know how to deal with GLib FDs under + ;; Windows, but we should wake up on any Windows event + (scheme_add_fd_eventmask fds QS_ALLINPUT) + ;; Normal FD handling under Unix variants: + (for ([i (in-range n)]) + (let* ([gfd (ptr-ref poll-fds _GPollFD i)] + [fd (GPollFD-fd gfd)] + [events (GPollFD-events gfd)]) + (when (not (zero? (bitwise-and events POLLIN))) + (scheme_fdset (scheme_get_fdset fds 0) fd)) + (when (not (zero? (bitwise-and events POLLOUT))) + (scheme_fdset (scheme_get_fdset fds 1) fd)) + (when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP)))) + (scheme_fdset (scheme_get_fdset fds 2) fd)))))))) (set-check-queue! gtk_events_pending) (set-queue-wakeup! install-wakeup) diff --git a/collects/mred/private/wx/gtk/w32.rkt b/collects/mred/private/wx/gtk/w32.rkt new file mode 100644 index 00000000..8e995ba6 --- /dev/null +++ b/collects/mred/private/wx/gtk/w32.rkt @@ -0,0 +1,32 @@ +#lang racket/base + +(provide QS_ALLINPUT) + +(define QS_KEY #x0001) +(define QS_MOUSEMOVE #x0002) +(define QS_MOUSEBUTTON #x0004) +(define QS_POSTMESSAGE #x0008) +(define QS_TIMER #x0010) +(define QS_PAINT #x0020) +(define QS_SENDMESSAGE #x0040) +(define QS_HOTKEY #x0080) +(define QS_ALLPOSTMESSAGE #x0100) +(define QS_RAWINPUT #x0400) +(define QS_MOUSE (bitwise-ior QS_MOUSEMOVE + QS_MOUSEBUTTON)) + +(define QS_INPUT (bitwise-ior QS_MOUSE + QS_KEY + QS_RAWINPUT)) +(define QS_ALLEVENTS (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY)) + +(define QS_ALLINPUT (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY + QS_SENDMESSAGE)) From 79d46e5164a637b08990115d762f844a3f607a9f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 09:17:50 -0600 Subject: [PATCH 176/462] concurrency repairs original commit: 3a99e9e82c30ef0a2693b444441c1fd3d87c0e34 --- collects/mred/private/moredialogs.rkt | 2 +- collects/mred/private/wx/cocoa/dialog.rkt | 2 +- collects/mred/private/wx/common/queue.rkt | 2 +- collects/mred/private/wx/gtk/dialog.rkt | 20 ++++++++++++-------- collects/mred/private/wxme/text.rkt | 2 +- collects/mred/private/wxtextfield.rkt | 2 +- 6 files changed, 17 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 3f9b1fc5..8f275043 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -208,7 +208,7 @@ ((done #t) #f #f))) init-val (list* 'single 'vertical-label style))] [p (make-object horizontal-pane% f)]) - (send p set-alignment 'right 'center) + (send p set-alignment 'right 'center) (send f stretchable-height #f) (ok-cancel (lambda () (make-object button% "OK" p (done #t) '(border))) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 2e696629..a07fc383 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -28,7 +28,7 @@ (let ([s (atomically (let ([s (or close-sema (make-semaphore))]) (unless close-sema (set! close-sema s)) - s))]) + (semaphore-peek-evt s)))]) (super show on?) (yield s) (void)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2f52f60a..f76205bf 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -355,7 +355,7 @@ (when v (handle-event v)) (yield evt))))] [else - (sync e)]))])) + (sync evt)]))])) (define event-dispatch-handler (make-parameter void)) (define (main-eventspace? e) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 3de209a7..6c063d65 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -3,6 +3,7 @@ ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" + "../../lock.rkt" "types.rkt" "utils.rkt" "frame.rkt") @@ -51,9 +52,10 @@ (unless on? (set! dialog-level 0)) (unless on? - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f))) + (atomically + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f)))) (super direct-show on?)) (define/override (center dir wrt) @@ -66,9 +68,11 @@ (define/override (show on?) (if on? - (unless close-sema - (let ([s (make-semaphore)]) - (set! close-sema s) - (super show on?) - (yield s))) + (let ([s (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + (semaphore-peek-evt s)))]) + (super show on?) + (yield s) + (void)) (super show on?)))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index e01fa2b4..42f2a300 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -4759,7 +4759,7 @@ (when (and resized? s-admin) (send s-admin resized #f)) - + (on-reflow))))))))))) (def/public (on-reflow) (void)) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index b12ee9a8..f958b5a7 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -241,7 +241,7 @@ ;; Exact (set! dy (inexact->exact dy)))) - + (when value (set-value value) (unless (string=? value "") From fee7c80590ad24e5cd2688c1654eb44fcf1117c3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 11:03:13 -0600 Subject: [PATCH 177/462] special-option-key for cocoa original commit: a7470471451607980b2331c0e56a83994687272b --- collects/mred/private/wx/cocoa/procs.rkt | 4 --- collects/mred/private/wx/cocoa/window.rkt | 31 ++++++++++++++++++++--- collects/tests/gracket/showkey.rkt | 10 +++++++- 3 files changed, 37 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index ecf789e1..7210efd2 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -10,8 +10,6 @@ "../common/handlers.rkt") (provide - special-control-key - special-option-key application-file-handler application-quit-handler application-about-handler @@ -62,8 +60,6 @@ (import-class NSScreen NSCursor) -(define-unimplemented special-control-key) -(define (special-option-key on?) (void)) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b1e703b5..5440658b 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -29,12 +29,29 @@ queue-window*-event request-flush-delay cancel-flush-delay - make-init-point) + make-init-point + + special-control-key + special-option-key) (define-local-member-name flip-client) ;; ---------------------------------------- +(define special-control-key? #f) +(define special-control-key + (case-lambda + [() special-control-key?] + [(on?) (set! special-control-key? (and on? #t))])) + +(define special-option-key? #f) +(define special-option-key + (case-lambda + [() special-option-key?] + [(on?) (set! special-option-key? (and on? #t))])) + +;; ---------------------------------------- + (define-objc-mixin (FocusResponder Superclass) [wxb] [-a _BOOL (acceptsFirstResponder) @@ -170,7 +187,8 @@ [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] [str (tell #:type _NSString event characters)] - [control? (bit? modifiers NSControlKeyMask)]) + [control? (bit? modifiers NSControlKeyMask)] + [option? (bit? modifiers NSAlternateKeyMask)]) (let-values ([(x y) (send wx window-point-to-view pos)]) (let ([k (new key-event% [key-code (or @@ -188,7 +206,7 @@ [shift-down (bit? modifiers NSShiftKeyMask)] [control-down control?] [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] + [alt-down option?] [x (->long x)] [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] @@ -199,6 +217,13 @@ (let ([alt-code (string-ref alt-str 0)]) (unless (equal? alt-code (send k get-key-code)) (send k set-other-altgr-key-code alt-code))))) + (when (and option? + special-option-key? + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () diff --git a/collects/tests/gracket/showkey.rkt b/collects/tests/gracket/showkey.rkt index 64de9155..124c4323 100644 --- a/collects/tests/gracket/showkey.rkt +++ b/collects/tests/gracket/showkey.rkt @@ -1,6 +1,14 @@ #lang racket/base (require racket/gui/base - racket/class) + racket/class + racket/cmdline) + +(command-line + #:once-each + [("--option") "set special Option key" + (special-option-key #t)] + [("--control") "set special Control key" + (special-control-key #t)]) (let () (define iter 0) From 627a12a4f4c3add9d4aa1090668f705d611a5863 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 11:29:17 -0600 Subject: [PATCH 178/462] small step toward new text hiliting original commit: 67ec13ac1a1f175fae1d25e78beeb7f215676c91 --- collects/mred/private/wx/cocoa/queue.rkt | 30 ++++++++++++++++++++---- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 357c8a7d..adf70a51 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -1,7 +1,8 @@ #lang scheme/base -(require ffi/objc - scheme/foreign +(require ffi/unsafe/objc + ffi/unsafe scheme/class + racket/draw/dc "pool.rkt" "utils.rkt" "const.rkt" @@ -10,8 +11,6 @@ "../common/handlers.rkt" "../../lock.rkt" "../common/freeze.rkt") -(unsafe!) -(objc-unsafe!) (provide app cocoa-start-event-pump @@ -27,7 +26,7 @@ queue-event yield) -(import-class NSApplication NSAutoreleasePool) +(import-class NSApplication NSAutoreleasePool NSColor) (import-protocol NSApplicationDelegate) (define app (tell NSApplication sharedApplication)) @@ -276,3 +275,24 @@ (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event (_fun #:atomic? #t _float _pointer -> _void)))) + +;; ------------------------------------------------------------ +;; Set highlight color + +(define-cocoa NSCalibratedRGBColorSpace _id) + +(define (install-system-highlight-color! r g b a) + (void)) + +(let ([hi (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (install-system-highlight-color! (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent)) + (as-color + (tell #:type _CGFloat hi alphaComponent)))) From b4d34b0b32f1288de8f31016b03732e22c23e9b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 07:36:52 -0600 Subject: [PATCH 179/462] generalize editor selection mechanism to support Windows style original commit: ae05eddf1437b8ae465d9bdfe8a605f7db022765 --- collects/mred/mred.rkt | 6 +- collects/mred/private/wx/cocoa/platform.rkt | 4 +- collects/mred/private/wx/cocoa/procs.rkt | 27 +- collects/mred/private/wx/cocoa/queue.rkt | 21 -- collects/mred/private/wx/gtk/canvas.rkt | 2 - collects/mred/private/wx/gtk/platform.rkt | 4 +- collects/mred/private/wx/gtk/procs.rkt | 13 +- collects/mred/private/wx/gtk/style.rkt | 85 ++++++ collects/mred/private/wx/gtk/utils.rkt | 1 + collects/mred/private/wx/platform.rkt | 4 +- collects/mred/private/wx/win32/platform.rkt | 4 +- collects/mred/private/wx/win32/procs.rkt | 8 +- collects/mred/private/wxme/editor-snip.rkt | 65 +++-- collects/mred/private/wxme/editor.rkt | 4 +- collects/mred/private/wxme/text.rkt | 249 ++++++++++-------- collects/mred/private/wxme/wx.rkt | 4 +- collects/scribblings/gui/editor-intf.scrbl | 8 +- .../scribblings/gui/editor-overview.scrbl | 9 +- collects/scribblings/gui/miscwin-funcs.scrbl | 12 + collects/scribblings/gui/snip-class.scrbl | 10 +- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 8 + 21 files changed, 367 insertions(+), 181 deletions(-) create mode 100644 collects/mred/private/wx/gtk/style.rkt diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 88477ae2..2fc3ba91 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -132,7 +132,9 @@ font% font-list% font-name-directory<%> - get-resource + get-highlight-background-color + get-highlight-text-color + get-resource get-the-editor-data-class-list get-the-snip-class-list image-snip% @@ -271,7 +273,7 @@ get-display-left-top-inset get-color-from-user get-font-from-user - append-editor-operation-menu-items + append-editor-operation-menu-items append-editor-font-menu-items get-top-level-focus-window get-top-level-edit-target-window diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index f6e408e8..345eefbe 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -101,4 +101,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 7210efd2..48d16a39 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -55,7 +55,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (import-class NSScreen NSCursor) @@ -117,3 +119,26 @@ (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) + +;; ------------------------------------------------------------ +;; Text & highlight color + +(import-class NSColor) + +(define-cocoa NSCalibratedRGBColorSpace _id) + +(define (get-highlight-background-color) + (let ([hi (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))))) + +(define (get-highlight-text-color) + #f) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index adf70a51..9210d293 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -275,24 +275,3 @@ (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event (_fun #:atomic? #t _float _pointer -> _void)))) - -;; ------------------------------------------------------------ -;; Set highlight color - -(define-cocoa NSCalibratedRGBColorSpace _id) - -(define (install-system-highlight-color! r g b a) - (void)) - -(let ([hi (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] - [as-color (lambda (v) - (inexact->exact (floor (* 255.0 v))))]) - (install-system-highlight-color! (as-color - (tell #:type _CGFloat hi redComponent)) - (as-color - (tell #:type _CGFloat hi greenComponent)) - (as-color - (tell #:type _CGFloat hi blueComponent)) - (as-color - (tell #:type _CGFloat hi alphaComponent)))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index c96d3144..6e11e437 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -173,8 +173,6 @@ (queue-window-event wx (lambda () (send wx do-scroll dir))))) #t) -(define-gtk gtk_entry_get_type (_fun -> _GType)) - (define canvas% (class (client-size-mixin window%) (init parent diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 00ccbd0e..c398f82b 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -101,4 +101,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 229e4d2a..1fe3242d 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -7,6 +7,7 @@ "filedialog.rkt" "types.rkt" "utils.rkt" + "style.rkt" "widget.rkt" "../common/handlers.rkt") @@ -58,7 +59,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (define-unimplemented special-control-key) (define (special-option-key on?) (void)) @@ -125,3 +128,11 @@ (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) + +(define (get-highlight-background-color) + (let-values ([(r g b) (get-selected-background-color)]) + (make-object color% r g b))) + +(define (get-highlight-text-color) + (let-values ([(r g b) (get-selected-text-color)]) + (make-object color% r g b))) diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt new file mode 100644 index 00000000..6d8550f5 --- /dev/null +++ b/collects/mred/private/wx/gtk/style.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require ffi/unsafe + "types.rkt" + "utils.rkt" + "init.rkt") + +(provide get-selected-text-color + get-selected-background-color) + +(define-cstruct _GdkColor + ([pixel _uint32] + [red _uint16] + [green _uint16] + [blue _uint16])) + +(define-cstruct _GtkStyle + ([fg1 _GdkColor] + [fg2 _GdkColor] + [fg3 _GdkColor] + [fg4 _GdkColor] + [fg5 _GdkColor] + [bg1 _GdkColor] + [bg2 _GdkColor] + [bg3 _GdkColor] + [bg4 _GdkColor] + [bg5 _GdkColor] + [light1 _GdkColor] + [light2 _GdkColor] + [light3 _GdkColor] + [light4 _GdkColor] + [light5 _GdkColor] + [dark1 _GdkColor] + [dark2 _GdkColor] + [dark3 _GdkColor] + [dark4 _GdkColor] + [dark5 _GdkColor] + [mid1 _GdkColor] + [mid2 _GdkColor] + [mid3 _GdkColor] + [mid4 _GdkColor] + [mid5 _GdkColor] + [text1 _GdkColor] + [text2 _GdkColor] + [text3 _GdkColor] + [text4 _GdkColor] + [text5 _GdkColor] + [base1 _GdkColor] + [base2 _GdkColor] + [base3 _GdkColor] + [base4 _GdkColor] + [base5 _GdkColor] + [text_aa1 _GdkColor] + [text_aa2 _GdkColor] + [text_aa3 _GdkColor] + [text_aa4 _GdkColor] + [text_aa5 _GdkColor] + [black _GdkColor] + [white _GdkColor] + [font_desc _pointer] ; PangoFontDescription * + ; ... + )) + +(define-gtk gtk_widget_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) +(define-gtk gtk_text_view_new (_fun -> _GtkWidget)) + +(define the-text-style + (let ([w (gtk_text_view_new)]) + (let ([style (gtk_widget_get_style w)]) + (g_object_ref style) + (begin0 + style + (g_object_ref_sink w) + (g_object_unref w))))) + +(define (extract-color-values c) + (define (s v) (bitwise-and #xFF (arithmetic-shift v -8))) + (values (s (GdkColor-red c)) + (s (GdkColor-green c)) + (s (GdkColor-blue c)))) + +(define (get-selected-text-color) + (extract-color-values (GtkStyle-text4 the-text-style))) + +(define (get-selected-background-color) + (extract-color-values (GtkStyle-base4 the-text-style))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 1785cb1e..6fa2987b 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -15,6 +15,7 @@ define-mz g_object_ref + g_object_ref_sink g_object_unref gobject-ref diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 729f2393..69690c98 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -79,5 +79,7 @@ application-quit-handler application-file-handler special-option-key - special-control-key) + special-control-key + get-highlight-background-color + get-highlight-text-color) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index ba59b565..9e8ccdfa 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -100,4 +100,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index d4d7d4ad..120851f6 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -49,7 +49,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (define-unimplemented special-control-key) @@ -102,4 +104,6 @@ (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) -(define-unimplemented can-show-print-setup?) \ No newline at end of file +(define-unimplemented can-show-print-setup?) +(define-unimplemented get-highlight-background-color) +(define-unimplemented get-highlight-text-color) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 63657249..0c74ec30 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -284,7 +284,7 @@ (def/override (draw [dc<%> dc] [real? x] [real? y] [real? left] [real? top] [real? right] [real? bottom] - [real? dx] [real? dy] [symbol? caret]) + [real? dx] [real? dy] [caret-status? caret]) (send my-admin with-dc dc x y @@ -320,6 +320,7 @@ (let ([bg-color (cond + [(pair? caret) #f] [(not use-style-bg?) (make-object color% 255 255 255)] [(send s-style get-transparent-text-backing) @@ -357,34 +358,40 @@ caret bg-color)) (when with-border? - (let* ([l (+ orig-x left-inset)] - [t (+ orig-y top-inset)] - [r (+ l w left-margin right-margin - (- (+ left-inset right-inset)) - -1)] - [b (+ t h top-margin bottom-margin - (- (+ top-inset bottom-inset)) - -1)]) - (let ([ml (max (min l right) left)] - [mr (max (min r right) left)] - [mt (max (min t bottom) top)] - [mb (max (min b bottom) top)]) - (when (and (l . >= . left) - (l . < . right) - (mt . < . mb)) - (send dc draw-line l mt l mb)) - (when (and (r . >= . left) - (r . < . right) - (mt . < . mb)) - (send dc draw-line r mt r mb)) - (when (and (t . >= . top) - (t . < . bottom) - (ml . < . mr)) - (send dc draw-line ml t mr t)) - (when (and (b . >= . top) - (b . < . bottom) - (ml . < . mr)) - (send dc draw-line ml b mr b))))))))))) + (let ([pen (send dc get-pen)]) + (when (and (pair? caret) + selected-text-color) + (send dc set-pen selected-text-color 1 'solid)) + (let* ([l (+ orig-x left-inset)] + [t (+ orig-y top-inset)] + [r (+ l w left-margin right-margin + (- (+ left-inset right-inset)) + -1)] + [b (+ t h top-margin bottom-margin + (- (+ top-inset bottom-inset)) + -1)]) + (let ([ml (max (min l right) left)] + [mr (max (min r right) left)] + [mt (max (min t bottom) top)] + [mb (max (min b bottom) top)]) + (when (and (l . >= . left) + (l . < . right) + (mt . < . mb)) + (send dc draw-line l mt l mb)) + (when (and (r . >= . left) + (r . < . right) + (mt . < . mb)) + (send dc draw-line r mt r mb)) + (when (and (t . >= . top) + (t . < . bottom) + (ml . < . mr)) + (send dc draw-line ml t mr t)) + (when (and (b . >= . top) + (b . < . bottom) + (ml . < . mr)) + (send dc draw-line ml b mr b)))) + (when (pair? caret) + (send dc set-pen pen)))))))))) (def/override (copy) (let* ([mb (and editor diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 4c88b64c..27138274 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -1266,14 +1266,14 @@ #f)) (def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (void)) (def/public (on-paint [any? pre?] [dc<%> dc] [real? l] [real? t] [real? r] [real? b] [real? dx] [real? dy] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret]) + [caret-status? show-caret]) (void)) (def/public (can-save-file? [path-string? filename] diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 42f2a300..3736bda0 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -47,8 +47,8 @@ (define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor)) (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) -(define outline-inactive-pen (send the-pen-list find-or-create-pen "BLACK" 1 'hilite)) -(define outline-brush (send the-brush-list find-or-create-brush "BLACK" 'hilite)) +(define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) +(define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") (define outline-nonowner-brush (let ([b (new brush%)]) (send b set-color "BLACK") @@ -4933,7 +4933,7 @@ ;; called by the administrator to trigger a redraw (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (cond [(or (width . <= . 0) (height . <= . 0)) (void)] @@ -4955,6 +4955,7 @@ (let ([show-caret (if (and caret-blinked? + (not (pair? show-caret)) (not (eq? show-caret 'no-caret)) (not s-caret-snip)) ;; maintain caret-blinked invariant @@ -4979,7 +4980,9 @@ (dc . is-a? . printer-dc%))] [show-xsel? (and ALLOW-X-STYLE-SELECTION? - (or (not (eq? 'show-caret show-caret)) s-caret-snip) + (or (not (eq? 'show-caret show-caret)) + (not (pair? show-caret)) + s-caret-snip) (eq? this editor-x-selection-owner) (not flash?) (not (= endpos startpos)))]) @@ -5078,7 +5081,8 @@ (let ([line (mline-find-location (unbox line-root-box) starty)]) - (when bg-color + (when (and bg-color + (not (pair? show-caret))) (let ([lsave-pen (send dc get-pen)] [lsave-brush (send dc get-brush)]) (let ([wb (if (and (= 255 (send bg-color red)) @@ -5099,7 +5103,8 @@ (let* ([call-on-paint (lambda (pre?) (on-paint pre? dc leftx starty rightx endy dx dy - (if (not s-caret-snip) + (if (or (pair? show-caret) + (not s-caret-snip)) show-caret 'no-caret)))] [paint-done @@ -5123,7 +5128,8 @@ (cond [(not line) (send (send s-style-list basic-style) switch-to dc old-style) - (when (and (eq? 'show-caret show-caret) (not s-caret-snip) + (when (and (eq? 'show-caret show-caret) + (not s-caret-snip) extra-line? (not pos-at-eol?) (= len -startpos) @@ -5142,106 +5148,123 @@ [last (snip->next (mline-last-snip line))] [bottombase (+ ycounter (mline-bottombase line))] [topbase (+ ycounter (mline-topbase line))]) - (let-values ([(hilite-some? hsxs hsxe hsys hsye old-style) - (let sloop ([snip first] - [p pcounter] - [x (mline-get-left-location line max-width)] - [hilite-some? #f] - [hsxs 0.0] - [hsxe 0.0] - [hsys 0.0] - [hsye 0.0] - [old-style old-style]) - (if (eq? snip last) - (values hilite-some? hsxs hsxe hsys hsye old-style) - (begin - (send (snip->style snip) switch-to dc old-style) - (let ([old-style (snip->style snip)]) - (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) - (send snip get-extent dc x ycounter w h descent space #f #f) - (let* ([align (send (snip->style snip) get-alignment)] - [down - (cond - [(eq? 'bottom align) - (+ (- bottombase h) descent)] - [(eq? 'top align) - (- topbase space)] - [else - (- (/ (+ topbase bottombase) 2) - (/ (- h descent space) 2) - space)])]) + (define (process-snips draw? maybe-hilite? old-style) + (let sloop ([snip first] + [p pcounter] + [x (mline-get-left-location line max-width)] + [hilite-some? #f] + [hsxs 0.0] + [hsxe 0.0] + [hsys 0.0] + [hsye 0.0] + [old-style old-style]) + (if (eq? snip last) + (values hilite-some? hsxs hsxe hsys hsye old-style) + (begin + (send (snip->style snip) switch-to dc old-style) + (let ([old-style (snip->style snip)]) + (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) + (send snip get-extent dc x ycounter w h descent space #f #f) + (let* ([align (send (snip->style snip) get-alignment)] + [down + (cond + [(eq? 'bottom align) + (+ (- bottombase h) descent)] + [(eq? 'top align) + (- topbase space)] + [else + (- (/ (+ topbase bottombase) 2) + (/ (- h descent space) 2) + space)])]) - (when (and (x . <= . rightx) - ((+ x w) . >= . leftx)) - (send snip draw dc (+ x dx) (+ down dy) - tleftx tstarty trightx tendy - dx dy - (if (eq? snip s-caret-snip) - show-caret - 'no-caret))) + (when draw? + (when (and (x . <= . rightx) + ((+ x w) . >= . leftx)) + (send snip draw dc (+ x dx) (+ down dy) + tleftx tstarty trightx tendy + dx dy + (if (pair? show-caret) + (cons p (+ p (snip->count snip))) + (if (eq? snip s-caret-snip) + show-caret + (if (and maybe-hilite? + (endpos . > . p) + (startpos . < . (+ p (snip->count snip)))) + (cons (max 0 (- startpos p)) + (min (snip->count snip) (- endpos p))) + 'no-caret)))))) - ;; the rules for hiliting are surprisingly complicated: - (let ([hilite? - (and - hilite-on? - (or show-xsel? - (and (not s-caret-snip) - (or (eq? 'show-caret show-caret) - (and (show-caret . showcaret>= . s-inactive-caret-threshold) - (not (= -endpos -startpos)))))) - (if pos-at-eol? - (= -startpos (+ p (snip->count snip))) - (or (and (-startpos . < . (+ p (snip->count snip))) - (-endpos . >= . p) - (or (= -endpos -startpos) (-endpos . > . p))) - (and (= (+ p (snip->count snip)) len) - (= len -startpos)))) - (or (not (has-flag? (snip->flags snip) NEWLINE)) - ;; end of line: - (or (not (= -startpos (+ p (snip->count snip)))) - (and (= -endpos -startpos) pos-at-eol?) - (and (not (= -endpos -startpos)) - (-startpos . < . (+ p (snip->count snip)))))) - (or (not (eq? snip first)) - ;; beginning of line: - (or (not (= p -endpos)) - (and (= -endpos -startpos) (not pos-at-eol?)) - (and (not (= -endpos -startpos)) - (-endpos . > . p)))))]) - - (if hilite? - (let*-values ([(bottom) (+ down h)] - [(hxs) (if (-startpos . <= . p) - (if (-startpos . < . p) - 0 - x) - (+ x (send snip partial-offset dc x ycounter - (- -startpos p))))] - [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) - (if (has-flag? (snip->flags snip) NEWLINE) - (if (= -startpos -endpos) - (values hxs bottom) - (values rightx - (+ ycounter (mline-h line)))) - (values (+ x w) bottom)) - (values (+ x (send snip partial-offset dc x ycounter - (- -endpos p))) - bottom))]) - - (let-values ([(hsxs hsxe hsys hsye) - (if (not hilite-some?) - (values hxs hxe down bottom) - (values hsxs hxe (min down hsys) (max hsye bottom)))]) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - #t hsxs hsxe hsys hsye - old-style))) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - hilite-some? hsxs hsxe hsys hsye - old-style)))))))))]) + ;; the rules for hiliting are surprisingly complicated: + (let ([hilite? + (and + hilite-on? + (or show-xsel? + (and (not s-caret-snip) + (or (eq? 'show-caret show-caret) + (and (show-caret . showcaret>= . s-inactive-caret-threshold) + (not (= -endpos -startpos)))))) + (if pos-at-eol? + (= -startpos (+ p (snip->count snip))) + (or (and (-startpos . < . (+ p (snip->count snip))) + (-endpos . >= . p) + (or (= -endpos -startpos) (-endpos . > . p))) + (and (= (+ p (snip->count snip)) len) + (= len -startpos)))) + (or (not (has-flag? (snip->flags snip) NEWLINE)) + ;; end of line: + (or (not (= -startpos (+ p (snip->count snip)))) + (and (= -endpos -startpos) pos-at-eol?) + (and (not (= -endpos -startpos)) + (-startpos . < . (+ p (snip->count snip)))))) + (or (not (eq? snip first)) + ;; beginning of line: + (or (not (= p -endpos)) + (and (= -endpos -startpos) (not pos-at-eol?)) + (and (not (= -endpos -startpos)) + (-endpos . > . p)))))]) + + (if hilite? + (let*-values ([(bottom) (+ down h)] + [(hxs) (if (-startpos . <= . p) + (if (-startpos . < . p) + 0 + x) + (+ x (send snip partial-offset dc x ycounter + (- -startpos p))))] + [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) + (if (has-flag? (snip->flags snip) NEWLINE) + (if (= -startpos -endpos) + (values hxs bottom) + (values rightx + (+ ycounter (mline-h line)))) + (values (+ x w) bottom)) + (values (+ x (send snip partial-offset dc x ycounter + (- -endpos p))) + bottom))]) + + (let-values ([(hsxs hsxe hsys hsye) + (if (not hilite-some?) + (values hxs hxe down bottom) + (values hsxs hxe (min down hsys) (max hsye bottom)))]) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + #t hsxs hsxe hsys hsye + old-style))) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + hilite-some? hsxs hsxe hsys hsye + old-style)))))))))) + (let*-values ([(draw-first?) + (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?) + (= -startpos -endpos) + (endpos . < . pcounter) + (startpos . > . (+ pcounter (mline-len line))))] + [(hilite-some? hsxs hsxe hsys hsye old-style) + (process-snips draw-first? #f old-style)]) (when (and (positive? wrap-bitmap-width) (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) last @@ -5314,11 +5337,17 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) - (lloop (mline-next line) - old-style - (+ ycounter (mline-h line)) - (+ pcounter (mline-len line)) - prevwasfirst))))]))))))))) + (let ([old-style + (if draw-first? + old-style + (let-values ([(_hilite-some? _hsxs _hsxe _hsys _hsye old-style) + (process-snips #t #t old-style)]) + old-style))]) + (lloop (mline-next line) + old-style + (+ ycounter (mline-h line)) + (+ pcounter (mline-len line)) + prevwasfirst)))))]))))))))) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index 97d3d6d4..1be64b3f 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -52,7 +52,9 @@ family-symbol? style-symbol? weight-symbol? - smoothing-symbol?) + smoothing-symbol? + get-highlight-background-color + get-highlight-text-color) (define (get-double-click-threshold) (get-double-click-time)) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index cf630721..4720f272 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1549,7 +1549,9 @@ Returns @scheme[(make-object image-snip% filename kind relative-path? inline?)]. [bottom real?] [dx real?] [dy real?] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -1888,7 +1890,9 @@ See also @method[editor<%> add-undo]. [y real?] [width (and/c real? (not/c negative?))] [height (and/c real? (not/c negative?))] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)] + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))] [background (or/c (is-a?/c color%) #f)]) void?]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 7bfd5d60..6558dc3a 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -601,8 +601,8 @@ When an editor contains other editors, it keeps track of caret appropriate sub-editor. When an editor or snip is drawn, an argument to the drawing method - specifies whether the caret should be drawn with the data. This - argument can be any of (in increasing order): + specifies whether the caret should be drawn with the data or whether + a selection spans the data. This argument can be any of: @itemize[ @@ -616,6 +616,11 @@ When an editor or snip is drawn, an argument to the drawing method @item{@indexed-scheme['show-caret] --- The caret should be drawn to show keyboard focus ownership.} + @item{@racket[(cons _start _end)] --- The caret is owned by an + enclosing region, and its selection spans the current editor or snip; + in the case of the snip, the selection spans elements @racket[_start] + through @racket[_end] positions within the snip.} + ] The @scheme['show-inactive-caret] display mode is useful for showing diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index c32cf3a2..a0291113 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -115,6 +115,18 @@ Returns the background color of a panel (usually some shade of gray) } + +@defproc[(get-highlight-background-color) (is-a?/c color%)]{ + +Returns the color drawn behind selected text.} + + +@defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ + +Returns the color used to draw selected text or @racket[#f] if +selected text is drawn with its usual color.} + + @defproc[(get-resource [section string?] [entry string?] [value (box/c (or/c string? exact-integer?))] diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index dd590f4a..33b5c46c 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -170,7 +170,9 @@ Called when the snip's editor's method is called, [bottom real?] [dx real?] [dy real?] - [draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -187,7 +189,11 @@ The @scheme[dx] and @scheme[dy] argument provide numbers that can be editor coordinates (as opposed to DC coordinates, which are used for drawing). -See @|drawcaretdiscuss| for information about @scheme[draw-caret]. +See @|drawcaretdiscuss| for information about +@scheme[draw-caret]. When @racket[draw-caret] is a pair, refrain from +drawing a background for the selected region, and use +@racket[get-highlight-text-color] when it is not @racket[#f] for +drawing text and other ``foreground'' elements. Before this method is called, the correct font, text color, and pen color for the snip's style will have been set in the drawing context diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index e70af0de..5ac70809 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -64,6 +64,14 @@ Changes to the drawing toolbox: * The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). + * The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or + `refresh' method can be a pair, which indicates that the caret is + owned by an enclosing display and the selection spans the snip or + editor. In that case, the snip or editor should refrain from + drawing a background for the selected region, and it should draw + the foreground in the color specified by + `get-highlight-text-color', if any. + Changes to the GUI toolbox: [Nothing to report, yet.] From 838731cde2ad84cc85b4e2b802077723fd2329f6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 09:49:30 -0600 Subject: [PATCH 180/462] fix gtk theme lookup original commit: e97cf6815b0fa98274fb26baf1f8b592635e2d72 --- collects/mred/private/wx/gtk/procs.rkt | 4 +++- collects/mred/private/wx/gtk/style.rkt | 16 +++++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 1fe3242d..23a7f8a0 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -135,4 +135,6 @@ (define (get-highlight-text-color) (let-values ([(r g b) (get-selected-text-color)]) - (make-object color% r g b))) + (if (and (zero? r) (zero? g) (zero? b)) + #f + (make-object color% r g b)))) diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt index 6d8550f5..f5d41e6b 100644 --- a/collects/mred/private/wx/gtk/style.rkt +++ b/collects/mred/private/wx/gtk/style.rkt @@ -13,8 +13,17 @@ [green _uint16] [blue _uint16])) +(define-cstruct _GTypeInstance + ([class _pointer])) + +(define-cstruct _GObject + ([g_type_instance _GTypeInstance] + [ref_count _uint] + [qdata _pointer])) + (define-cstruct _GtkStyle - ([fg1 _GdkColor] + ([obj _GObject] + [fg1 _GdkColor] [fg2 _GdkColor] [fg3 _GdkColor] [fg4 _GdkColor] @@ -61,11 +70,12 @@ )) (define-gtk gtk_widget_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) +(define-gtk gtk_rc_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) (define-gtk gtk_text_view_new (_fun -> _GtkWidget)) (define the-text-style (let ([w (gtk_text_view_new)]) - (let ([style (gtk_widget_get_style w)]) + (let ([style (gtk_rc_get_style w)]) (g_object_ref style) (begin0 style @@ -73,7 +83,7 @@ (g_object_unref w))))) (define (extract-color-values c) - (define (s v) (bitwise-and #xFF (arithmetic-shift v -8))) + (define (s v) (arithmetic-shift v -8)) (values (s (GdkColor-red c)) (s (GdkColor-green c)) (s (GdkColor-blue c)))) From bbca7106e2dab599442c42ab08ee040045a68d05 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 12:32:26 -0600 Subject: [PATCH 181/462] access foreign libs more consistently under Unix original commit: 42610ccecb559d9847aea9581c3bbc38a088b6a7 --- collects/mred/private/wx/gtk/utils.rkt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 6fa2987b..f91f6a96 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -56,26 +56,36 @@ (case (system-type) [(windows) (ffi-lib "libgobject-2.0-0")] + [(unix) + (ffi-lib "libgobject-2.0" '("0"))] [else gdk-lib])) (define glib-lib (case (system-type) [(windows) (ffi-lib "libglib-2.0-0")] + [(unix) + (ffi-lib "libglib-2.0" '("0"))] [else gdk-lib])) (define gio-lib (case (system-type) [(windows) (ffi-lib "libgio-2.0-0")] + [(unix) + (ffi-lib "libgio-2.0" '("0"))] [else gdk-lib])) (define gmodule-lib (case (system-type) [(windows) (ffi-lib "libgmodule-2.0-0")] + [(unix) + (ffi-lib "libgmodule-2.0" '("0"))] [else gdk-lib])) (define gdk_pixbuf-lib (case (system-type) [(windows) (ffi-lib "libgdk_pixbuf-2.0-0")] + [(unix) + (ffi-lib "libgdk_pixbuf-2.0" '("0"))] [else gdk-lib])) (define gtk-lib (case (system-type) From 35b1475bb1475052a8a1f3791cba3555090c1d0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 13:52:11 -0600 Subject: [PATCH 182/462] update hierlist for new selection drawing original commit: 955df62409ce23a2d80f967552b4aaf66c3f132f --- collects/mrlib/hierlist/hierlist-unit.rkt | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/mrlib/hierlist/hierlist-unit.rkt b/collects/mrlib/hierlist/hierlist-unit.rkt index 266efa79..5f946b68 100644 --- a/collects/mrlib/hierlist/hierlist-unit.rkt +++ b/collects/mrlib/hierlist/hierlist-unit.rkt @@ -27,10 +27,10 @@ (define transparent (make-object brush% "WHITE" 'transparent)) (define transparent-pen (make-object pen% "WHITE" 1 'transparent)) - (define black-xor-pen (make-object pen% "BLACK" 1 'hilite)) + (define black-xor-pen (make-object pen% (get-highlight-background-color) 1 'solid)) (define red (make-object brush% "RED" 'solid)) (define blue (make-object brush% "BLUE" 'solid)) - (define black-xor (make-object brush% "BLACK" 'hilite)) + (define black-xor (make-object brush% (get-highlight-background-color) 'solid)) (define arrow-cursor (make-object cursor% 'arrow)) (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap) @@ -285,9 +285,17 @@ (set-max-width (if (positive? w) w 'none)))))])] + [refresh (lambda (x y width height draw-caret background) + (super refresh x y width height + (if (and selected? + (or (not (send top show-focus)) + (send top has-focus?))) + (cons 0 1) + draw-caret) + background))] [on-paint (lambda (pre? dc left top_ right bottom dx dy caret) - (when (and (not pre?) selected?) + (when (and pre? selected?) (let ([b (send dc get-brush)] [p (send dc get-pen)] [filled? (or (not (send top show-focus)) @@ -652,7 +660,7 @@ (define hierarchical-list% (class100 editor-canvas% (parent [style '(no-hscroll)]) - (inherit min-width min-height allow-tab-exit) + (inherit min-width min-height allow-tab-exit refresh) (rename [super-on-char on-char] [super-on-focus on-focus]) (public From 3a0c3853be495d418f0f84f5fdee1a4dcc49e5e8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 13:52:30 -0600 Subject: [PATCH 183/462] fix focus problems and implement send-message-to-window in cocoa original commit: 2a4ea2ef98cd95a31934d28ccb84a698661e26bb --- collects/mred/mred-sig.rkt | 2 ++ collects/mred/private/wx/cocoa/frame.rkt | 21 +++++++++++++++++++-- collects/mred/private/wx/cocoa/procs.rkt | 3 +-- collects/mred/private/wx/cocoa/window.rkt | 5 ++++- collects/mred/private/wxcanvas.rkt | 2 +- 5 files changed, 27 insertions(+), 6 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 23d0fef9..7f41132b 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -91,6 +91,8 @@ get-font-from-user get-page-setup-from-user get-panel-background get-ps-setup-from-user +get-highlight-background-color +get-highlight-text-color get-resource get-text-from-user get-the-editor-data-class-list diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3c95a7b9..21141ded 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -16,12 +16,13 @@ (unsafe!) (objc-unsafe!) -(provide frame%) +(provide frame% + location->window) ;; ---------------------------------------- (import-class NSWindow NSGraphicsContext NSMenu NSPanel - NSApplication NSAutoreleasePool) + NSApplication NSAutoreleasePool NSScreen) (define front #f) @@ -30,6 +31,8 @@ (define dialog-level-counter 0) +(define all-windows (make-hash)) + (define-objc-mixin (MyWindowMethods Superclass) [wxb] [-a _scheme (getEventspace) @@ -242,6 +245,10 @@ [root-fake-frame (send root-fake-frame install-mb)] [else (void)])))) (register-frame-shown this on?) + (let ([num (tell #:type _NSInteger cocoa windowNumber)]) + (if on? + (hash-set! all-windows num this) + (hash-remove! all-windows num))) (when on? (let ([b (eventspace-wait-cursor-count (get-eventspace))]) (set-wait-cursor-mode (not (zero? b)))))))) @@ -436,3 +443,13 @@ (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)))) + +;; ---------------------------------------- + +(define (location->window x y) + (let ([n (tell #:type _NSInteger NSWindow + windowNumberAtPoint: #:type _NSPoint + (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) + belowWindowWithWindowNumber: #:type _NSInteger 0)]) + (atomically (hash-ref all-windows n #f)))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 48d16a39..00744298 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -6,6 +6,7 @@ ffi/unsafe/objc "utils.rkt" "types.rkt" + "frame.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -25,7 +26,6 @@ shortcut-visible-in-label? in-atomic-region set-menu-tester - location->window set-dialogs set-executer send-event @@ -74,7 +74,6 @@ (define-unimplemented in-atomic-region) (define (set-menu-tester proc) (void)) -(define-unimplemented location->window) (define (set-dialogs . args) (void)) (define (set-executer proc) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5440658b..e6899810 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -319,7 +319,10 @@ (with-autorelease (tellv cocoa removeFromSuperview))) (set! is-on? (and on? #t)))) - (maybe-register-as-child parent on?)) + (maybe-register-as-child parent on?) + (unless on? + (focus-is-on #f) + (is-responder this #f))) (define/public (maybe-register-as-child parent on?) (void)) (define/public (register-as-child parent on?) diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 60cc8549..94da953f 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/collects/mred/private/wxcanvas.rkt @@ -220,4 +220,4 @@ (define/override (on-scroll e) (editor-canvas-on-scroll)) (super-new) - (set-no-expose-focus)))) + #;(set-no-expose-focus)))) From 9c68ef1f459f7473f1c7e4875376eb447c550696 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 15:26:21 -0600 Subject: [PATCH 184/462] fix various cocoa problems original commit: 8ed2fba67d2503b31b8caadf30e191e729d46a62 --- collects/mred/private/wx/cocoa/button.rkt | 6 +- collects/mred/private/wx/cocoa/canvas.rkt | 56 ++++++++++++------- collects/mred/private/wx/cocoa/choice.rkt | 7 ++- collects/mred/private/wx/cocoa/frame.rkt | 32 +++++++---- collects/mred/private/wx/cocoa/list-box.rkt | 8 ++- collects/mred/private/wx/cocoa/message.rkt | 4 +- collects/mred/private/wx/cocoa/panel.rkt | 10 +++- collects/mred/private/wx/cocoa/radio-box.rkt | 7 ++- collects/mred/private/wx/cocoa/slider.rkt | 7 ++- collects/mred/private/wx/cocoa/tab-panel.rkt | 8 ++- collects/mred/private/wx/cocoa/window.rkt | 29 +++++++--- .../mred/private/wx/common/backing-dc.rkt | 3 + 12 files changed, 124 insertions(+), 53 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 93e87017..936af610 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -33,7 +33,8 @@ (init parent cb label x y w h style font [button-type #f]) (init-field [event-type 'button]) - (inherit get-cocoa get-cocoa-window init-font) + (inherit get-cocoa get-cocoa-window init-font + register-as-child) (define button-cocoa (let ([cocoa @@ -119,6 +120,9 @@ (define/override (get-cocoa-control) button-cocoa) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + (define/override (set-label label) (cond [(string? label) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 19d2d4d2..ba785fce 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -202,27 +202,37 @@ (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) (super focus-is-on on?)) - ;; Avoid multiple queued paints: - (define paint-queued? #f) + ;; Avoid multiple queued paints, and also allow cancel + ;; of queued paint: + (define paint-queued #f) ; #f or (box #t) (define/public (queue-paint) ;; can be called from any thread, including the event-pump thread - (unless paint-queued? - (set! paint-queued? #t) - (let ([req (request-flush-delay (get-cocoa-window))]) - (queue-window-event this (lambda () - (set! paint-queued? #f) - (when (is-shown-to-root?) - (send dc reset-backing-retained) ; start with a clean slate - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (queue-backing-flush) - (cancel-flush-delay req))))))) + (unless paint-queued + (let ([b (box #t)]) + (set! paint-queued b) + (let ([req (request-flush-delay (get-cocoa-window))]) + (queue-window-event this (lambda () + (do-on-paint req b))))))) + + (define/private (do-on-paint req b) + ;; only called in the handler thread + (when (or (not b) (unbox b)) + (let ([pq paint-queued]) + (when pq (set-box! pq #f))) + (set! paint-queued #f) + (when (or (not b) (is-shown-to-root?)) + (send dc reset-backing-retained) ; start with a clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (queue-backing-flush))) + (when req + (cancel-flush-delay req))) (define/public (paint-or-queue-paint) (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) @@ -231,6 +241,11 @@ (queue-paint) #f))) + (define/override (paint-children) + (when (or paint-queued + (not (send dc can-backing-flush?))) + (do-on-paint #f #f))) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread (queue-paint)) @@ -283,7 +298,7 @@ (define/public (get-dc) dc) - (define/public (fix-dc [refresh? #t]) + (define/override (fix-dc [refresh? #t]) (when (dc . is-a? . dc%) (send dc reset-backing-retained) (send dc set-auto-scroll @@ -608,8 +623,7 @@ (define/override (definitely-wants-event? e) ;; Called in Cocoa event-handling mode - (when (and is-combo? - (e . is-a? . mouse-event%) + (when (and (e . is-a? . mouse-event%) (send e button-down? 'left)) (set-focus)) (or (not is-combo?) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index d9caac07..b80f27d6 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -28,7 +28,7 @@ (init parent cb label x y w h choices style font) - (inherit get-cocoa init-font) + (inherit get-cocoa init-font register-as-child) (super-new [parent parent] [cocoa @@ -68,4 +68,7 @@ (define/public (append lbl) (tellv (get-cocoa) insertItemWithTitle: #:type _NSString lbl - atIndex: #:type _NSInteger (number)))) + atIndex: #:type _NSInteger (number))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 21141ded..98a89cac 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -254,11 +254,21 @@ (set-wait-cursor-mode (not (zero? b)))))))) (define/override (show on?) - (when on? - (when (eventspace-shutdown? (get-eventspace)) - (error (string->symbol - (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%))) - "the eventspace hash been shutdown"))) + (let ([es (get-eventspace)]) + (when on? + (when (eventspace-shutdown? es) + (error (string->symbol + (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%))) + "the eventspace hash been shutdown")) + (when saved-child + (if (eq? (current-thread) (eventspace-handler-thread es)) + (send saved-child paint-children) + (let ([s (make-semaphore)]) + (queue-callback (lambda () + (when saved-child + (send saved-child paint-children)) + (semaphore-post s))) + (sync/timeout 0.2 s)))))) (direct-show on?)) (define/public (destroy) @@ -305,11 +315,13 @@ (lambda () (send wx on-kill-focus))))) (define/override (is-responder wx on?) - (if on? - (set! first-responder wx) - (set! first-responder #f)) - (when is-main? - (do-notify-responder wx on?))) + (unless (and (not on?) + (not (eq? first-responder wx))) + (if on? + (set! first-responder wx) + (set! first-responder #f)) + (when is-main? + (do-notify-responder wx on?)))) (define/public (install-wait-cursor) (when (positive? (eventspace-wait-cursor-count (get-eventspace))) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index ea9ee562..e25fb0f1 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -59,7 +59,8 @@ label kind x y w h choices style font label-font) - (inherit set-size init-font) + (inherit set-size init-font + register-as-child) (define source (as-objc-allocation (tell (tell MyDataSource alloc) init))) @@ -194,4 +195,7 @@ (define/public (reset) (tellv content-cocoa noteNumberOfRowsChanged) - (tellv content-cocoa reloadData))) + (tellv content-cocoa reloadData)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 1f2510da..458b3fc3 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -32,11 +32,11 @@ "NSApplicationPath"))) (define-objc-class MyTextField NSTextField - #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + #:mixins (KeyMouseResponder CursorDisplayer) [wxb]) (define-objc-class MyImageView NSImageView - #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + #:mixins (KeyMouseResponder CursorDisplayer) [wxb]) (defclass message% item% diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 1ef4c77e..3837042f 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -30,9 +30,17 @@ (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) - (define/public (fix-dc) + (define/override (fix-dc) (for ([child (in-list children)]) (send child fix-dc))) + + (define/override (hide-children) + (for ([child (in-list children)]) + (send child hide-children))) + + (define/override (paint-children) + (for ([child (in-list children)]) + (send child paint-children))) (define/override (set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 364e1169..3a0e9b57 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -64,7 +64,7 @@ val style font) - (inherit get-cocoa set-focus init-font) + (inherit get-cocoa set-focus init-font register-as-child) (define horiz? (and (memq 'horizontal style) #t)) @@ -136,4 +136,7 @@ (if horiz? (tell #:type _NSInteger (get-cocoa) selectedColumn) (tell #:type _NSInteger (get-cocoa) selectedRow))) - (define/public (number) count)) + (define/public (number) count) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 7af719fb..246d402d 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -40,7 +40,7 @@ x y w style font) - (inherit get-cocoa) + (inherit get-cocoa register-as-child) (super-new [parent parent] [cocoa (let ([cocoa (as-objc-allocation @@ -76,5 +76,8 @@ (define/public (set-value v) (tellv cocoa setDoubleValue: #:type _double* v)) (define/public (get-value) - (inexact->exact (floor (tell #:type _double cocoa doubleValue))))) + (inexact->exact (floor (tell #:type _double cocoa doubleValue)))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 4662c0d4..68e29eab 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -40,7 +40,7 @@ x y w h style labels) - (inherit get-cocoa) + (inherit get-cocoa register-as-child) (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) @@ -147,4 +147,8 @@ [no-show? (memq 'deleted style)]) (when control-cocoa - (set-ivar! control-cocoa wxb (->wxb this)))) + (set-ivar! control-cocoa wxb (->wxb this))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) + diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index e6899810..a7db02cd 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -287,9 +287,21 @@ (define/public (focus-is-on on?) (void)) + + (define is-responder? #f) (define/public (is-responder wx on?) - (send parent is-responder wx on?)) + (unless (eq? on? is-responder?) + (set! is-responder? (and on? #t)) + (send parent is-responder wx on?))) + + (define/public (hide-children) + (is-responder this #f) + (focus-is-on #f)) + (define/public (fix-dc) + (void)) + (define/public (paint-children) + (void)) (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) @@ -321,9 +333,11 @@ (set! is-on? (and on? #t)))) (maybe-register-as-child parent on?) (unless on? - (focus-is-on #f) + (hide-children) (is-responder this #f))) (define/public (maybe-register-as-child parent on?) + ;; override this to call register-as-child if the window + ;; can have the focus or otherwise needs show-state notifications. (void)) (define/public (register-as-child parent on?) (send parent register-child this on?)) @@ -538,12 +552,9 @@ (when wx (queue-event (send wx get-eventspace) (lambda () (proc wx)))))) -(define depth 0) - (define (request-flush-delay cocoa-win) (atomically (let ([req (box cocoa-win)]) - (set! depth (add1 depth)) (tellv cocoa-win disableFlushWindow) (add-event-boundary-sometimes-callback! req @@ -551,9 +562,8 @@ ;; in atomic mode (when (unbox req) (set-box! req #f) - (set! depth (sub1 depth)) (tellv cocoa-win enableFlushWindow) - (tellv cocoa-win flushWindow)))) + (tellv cocoa-win flushWindowIfNeeded)))) req))) (define (cancel-flush-delay req) @@ -561,8 +571,11 @@ (let ([cocoa-win (unbox req)]) (when cocoa-win (set-box! req #f) - (set! depth (sub1 depth)) (tellv cocoa-win enableFlushWindow) + (add-event-boundary-sometimes-callback! + cocoa-win + (lambda (v) + (tellv cocoa-win flushWindowIfNeeded))) (remove-event-boundary-callback! req))))) (define (make-init-point x y) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 922894e0..7e7a5dac 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -62,6 +62,9 @@ [else (reset-backing-retained proc) #t])) + + (define/public (can-backing-flush?) + (and retained-cr #t)) (define/public (reset-backing-retained [proc void]) (let ([cr retained-cr]) From c31c8b916362b904e2383fde8c164c94c6824e47 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 17:23:33 -0600 Subject: [PATCH 185/462] more cocoa refresh refinements original commit: 31e46eb8b3ef9a0a0f4ed3c18580718c9b6520ad --- collects/mred/private/wx/cocoa/canvas.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 7 +------ collects/mred/private/wx/common/backing-dc.rkt | 2 ++ collects/mred/private/wx/gtk/canvas.rkt | 1 + 4 files changed, 5 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index ba785fce..cedc2c82 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -223,6 +223,7 @@ (set! paint-queued #f) (when (or (not b) (is-shown-to-root?)) (send dc reset-backing-retained) ; start with a clean slate + (send dc ensure-ready) (let ([bg (get-canvas-background)]) (when bg (let ([old-bg (send dc get-background)]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index a7db02cd..36715256 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -562,8 +562,7 @@ ;; in atomic mode (when (unbox req) (set-box! req #f) - (tellv cocoa-win enableFlushWindow) - (tellv cocoa-win flushWindowIfNeeded)))) + (tellv cocoa-win enableFlushWindow)))) req))) (define (cancel-flush-delay req) @@ -572,10 +571,6 @@ (when cocoa-win (set-box! req #f) (tellv cocoa-win enableFlushWindow) - (add-event-boundary-sometimes-callback! - cocoa-win - (lambda (v) - (tellv cocoa-win flushWindowIfNeeded))) (remove-event-boundary-callback! req))))) (define (make-init-point x y) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 7e7a5dac..b711207e 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -90,6 +90,8 @@ (define/public (get-bitmap%) bitmap%) + (define/public (ensure-ready) (get-cr)) + (define/override (get-cr) (or retained-cr (let ([w (box 0)] diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 6e11e437..1e40e7c0 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -347,6 +347,7 @@ (set! paint-queued? #f) (set! now-drawing? #t) (send dc reset-backing-retained) ; clean slate + (send dc ensure-ready) (let ([bg (get-canvas-background)]) (when bg (let ([old-bg (send dc get-background)]) From 6c367a0dcbc6653dde65ab074b8f5de9fb87ed54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 19:10:55 -0600 Subject: [PATCH 186/462] new queue level for refresh events original commit: f1e2db412f45217bbcdf362c2bdc5186089284e7 --- collects/mred/private/wx/cocoa/canvas.rkt | 5 ++-- collects/mred/private/wx/cocoa/queue.rkt | 7 +++++ collects/mred/private/wx/cocoa/window.rkt | 23 +++++++++++++-- collects/mred/private/wx/common/queue.rkt | 25 ++++++++++++++++- collects/mred/private/wx/gtk/canvas.rkt | 34 ++++++++++++----------- collects/mred/private/wx/gtk/window.rkt | 3 ++ 6 files changed, 76 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index cedc2c82..5ba1e691 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -212,8 +212,9 @@ (let ([b (box #t)]) (set! paint-queued b) (let ([req (request-flush-delay (get-cocoa-window))]) - (queue-window-event this (lambda () - (do-on-paint req b))))))) + (queue-window-refresh-event + this + (lambda () (do-on-paint req b))))))) (define/private (do-on-paint req b) ;; only called in the handler thread diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9210d293..9b2c2fea 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -21,6 +21,8 @@ set-menu-bar-hooks! post-dummy-event + try-to-sync-refresh + ;; from common/queue: current-eventspace queue-event @@ -255,6 +257,11 @@ ;; Called through an atomic callback: (lambda () (check-one-event #f #f))) +(define (try-to-sync-refresh) + (atomically + (pre-event-sync #t) + (check-one-event #f #f))) + ;; ------------------------------------------------------------ ;; Install an alternate "sleep" function (in the PLT Scheme core) ;; that wakes up if any Cocoa event is ready. diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 36715256..bd29c17a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -26,6 +26,7 @@ CursorDisplayer queue-window-event + queue-window-refresh-event queue-window*-event request-flush-delay cancel-flush-delay @@ -227,7 +228,7 @@ (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () - (send wx dispatch-on-char k #f))) + (send wx dispatch-on-char/sync k))) #t) (constrained-reply (send wx get-eventspace) (lambda () (send wx dispatch-on-char k #t)) @@ -257,7 +258,7 @@ (if (send wx definitely-wants-event? m) (begin (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) + (send wx dispatch-on-event/sync m))) #t) (constrained-reply (send wx get-eventspace) (lambda () (send wx dispatch-on-event m #t)) @@ -441,12 +442,27 @@ ;; Called in Cocoa event-handling mode #f) + (define/private (pre-event-refresh) + ;; Since we break the connection between the + ;; Cocoa queue and event handling, we'd like to + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corersponding + ;; stream of screen updates. + (void)) + + (define/public (dispatch-on-char/sync e) + (pre-event-refresh) + (dispatch-on-char e #f)) (define/public (dispatch-on-char e just-pre?) (cond [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) + + (define/public (dispatch-on-event/sync e) + (pre-event-refresh) + (dispatch-on-event e #f)) (define/public (dispatch-on-event e just-pre?) (cond [(other-modal? this) #t] @@ -547,6 +563,9 @@ (define (queue-window-event wx thunk) (queue-event (send wx get-eventspace) thunk)) +(define (queue-window-refresh-event wx thunk) + (queue-refresh-event (send wx get-eventspace) thunk)) + (define (queue-window*-event wxb proc) (let ([wx (->wx wxb)]) (when wx diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index f76205bf..6f524ac0 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -19,7 +19,9 @@ eventspace? current-eventspace queue-event + queue-refresh-event yield + yield-refresh (rename-out [make-new-eventspace make-eventspace]) event-dispatch-handler @@ -176,6 +178,7 @@ (let ([count 0]) (let ([lo (mcons #f #f)] [med (mcons #f #f)] + [refresh (mcons #f #f)] [hi (mcons #f #f)] [timer (box '())] [timer-counter 0] @@ -224,6 +227,7 @@ (case (car v) [(lo) (enqueue val lo)] [(med) (enqueue val med)] + [(refresh) (enqueue val refresh)] [(hi) (enqueue val hi)] [(timer-add) (set! timer-counter (add1 timer-counter)) @@ -272,12 +276,19 @@ (or (first hi) (timer-first-ready timer) (first med) + (first refresh) (first lo) (timer-first-wait timer) ;; nothing else ready... never-evt))]) (end-atomic) - e))])))) + e))] + [(_1 _2) + ;; Dequeue only refresh event + (start-atomic) + (begin0 + (or (first refresh) never-evt) + (end-atomic))])))) frames (semaphore-peek-evt done-sema) #f @@ -313,6 +324,9 @@ (define (queue-event eventspace thunk [level 'med]) ((eventspace-queue-proc eventspace) (cons level thunk))) +(define (queue-refresh-event eventspace thunk) + ((eventspace-queue-proc eventspace) (cons 'refresh thunk))) + (define (handle-event thunk) (let/ec esc (let ([done? #f]) @@ -357,6 +371,15 @@ [else (sync evt)]))])) +(define yield-refresh + (lambda () + (let ([e (current-eventspace)]) + (when (eq? (current-thread) (eventspace-handler-thread e)) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))]) + (when v + (handle-event v) + (yield-refresh))))))) + (define event-dispatch-handler (make-parameter void)) (define (main-eventspace? e) (eq? e main-eventspace)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 1e40e7c0..a046cde1 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -343,22 +343,24 @@ ;; can be called from any thread, including the event-pump thread (unless paint-queued? (set! paint-queued? #t) - (queue-window-event this (lambda () - (set! paint-queued? #f) - (set! now-drawing? #t) - (send dc reset-backing-retained) ; clean slate - (send dc ensure-ready) - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh)))))) + (queue-window-refresh-event + this + (lambda () + (set! paint-queued? #f) + (set! now-drawing? #t) + (send dc reset-backing-retained) ; clean slate + (send dc ensure-ready) + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (set! now-drawing? #f) + (when refresh-after-drawing? + (set! refresh-after-drawing? #f) + (refresh)))))) (define/public (paint-or-queue-paint) (or (do-backing-flush this dc (if is-combo? diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 321eb1bb..6b7d6335 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -19,6 +19,7 @@ (provide window% gtk->wx queue-window-event + queue-window-refresh-event gtk_widget_show gtk_widget_hide @@ -544,3 +545,5 @@ (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk)) From 4c7b49117e4aafd4c6b86fca350f58862b2d7c16 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 19:17:48 -0600 Subject: [PATCH 187/462] gtk key-handling fixes original commit: 9d1ac67287ada469943582d6c150e826b6a5269f --- collects/mred/private/wx/gtk/keycode.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 37 +++++++++++++++--------- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt index 99afa09c..e4e56935 100644 --- a/collects/mred/private/wx/gtk/keycode.rkt +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -8,7 +8,7 @@ (#xff09 . #\tab) (#xff0a . #\newline) (#xff0d . #\return) - (#xff1b . #\u1B); escape + (#xff1b . escape) ; escape (#xff50 . home) (#xff51 . left) (#xff52 . up) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 6b7d6335..703bf580 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -134,8 +134,9 @@ (or (map-key-code kv) (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (keyval->code (GdkEventKey-keyval event))] [k (new key-event% - [key-code (keyval->code (GdkEventKey-keyval event))] + [key-code key-code] [shift-down (bit? modifiers GDK_SHIFT_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)] [meta-down (bit? modifiers GDK_META_MASK)] @@ -144,18 +145,28 @@ [y 0] [time-stamp (GdkEventKey-time event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (let-values ([(s ag sag cl) (get-alts event)]) - (when s (send k set-other-shift-key-code (keyval->code s))) - (when ag (send k set-other-altgr-key-code (keyval->code ag))) - (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) - (when cl (send k set-other-caps-key-code (keyval->code cl)))) - (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))))))) + (when (or (not (equal? #\u0000 key-code)) + (let-values ([(s ag sag cl) (get-alts event)] + [(keyval->code*) (lambda (v) + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 key-code)) + 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 (keyval->code s))) + (when ag (send k set-other-altgr-key-code (keyval->code ag))) + (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) + (when cl (send k set-other-caps-key-code (keyval->code cl))) + (or s ag sag cl)))) + (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) From 68f291d8f8d700a42f4de76924467a2e2eb307c4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 19:25:11 -0600 Subject: [PATCH 188/462] key release events original commit: 8c9e2397986bf7fb51ff1f049b1c2a474a5fb588 --- collects/mred/private/wx/cocoa/window.rkt | 11 ++- collects/mred/private/wx/gtk/canvas.rkt | 1 + collects/mred/private/wx/gtk/window.rkt | 97 +++++++++++++---------- 3 files changed, 65 insertions(+), 44 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index bd29c17a..7dbac31b 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -126,7 +126,10 @@ (super-tell #:type _void otherMouseDragged: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event self) + (unless (do-key-event wxb event self #t) + (super-tell #:type _void keyDown: event))] + [-a _void (keyUp: [_id event]) + (unless (do-key-event wxb event self #f) (super-tell #:type _void keyDown: event))] [-a _void (insertText: [_NSString str]) (let ([cit (current-insert-text)]) @@ -167,7 +170,7 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event self) +(define (do-key-event wxb event self down?) (let ([wx (->wx wxb)]) (and wx @@ -225,6 +228,10 @@ (let ([other (send k get-other-altgr-key-code)]) (send k set-other-altgr-key-code (send k get-key-code)) (send k set-key-code other))) + (unless 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 definitely-wants-event? k) (begin (queue-window-event wx (lambda () diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index a046cde1..33bf7755 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -296,6 +296,7 @@ (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_KEY_RELEASE_MASK GDK_BUTTON_PRESS_MASK GDK_BUTTON_RELEASE_MASK GDK_POINTER_MOTION_MASK diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 703bf580..71ad4fdd 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -125,48 +125,60 @@ (define-signal-handler connect-key-press "key-press-event" (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) - (let ([wx (gtk->wx gtk)]) - (and - wx - (let* ([modifiers (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 (keyval->code (GdkEventKey-keyval event))] - [k (new key-event% - [key-code key-code] - [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)] - [x 0] - [y 0] - [time-stamp (GdkEventKey-time event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (when (or (not (equal? #\u0000 key-code)) - (let-values ([(s ag sag cl) (get-alts event)] - [(keyval->code*) (lambda (v) - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 key-code)) - 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 (keyval->code s))) - (when ag (send k set-other-altgr-key-code (keyval->code ag))) - (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) - (when cl (send k set-other-caps-key-code (keyval->code cl))) - (or s ag sag cl)))) - (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)))))))) + (do-key-event gtk event #t))) + +(define-signal-handler connect-key-release "key-release-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (do-key-event gtk event #f))) + +(define (do-key-event gtk event down?) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (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 (keyval->code (GdkEventKey-keyval event))] + [k (new key-event% + [key-code key-code] + [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)] + [x 0] + [y 0] + [time-stamp (GdkEventKey-time event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (when (or (not (equal? #\u0000 key-code)) + (let-values ([(s ag sag cl) (get-alts event)] + [(keyval->code*) (lambda (v) + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 key-code)) + 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 (keyval->code s))) + (when ag (send k set-other-altgr-key-code (keyval->code ag))) + (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) + (when cl (send k set-other-caps-key-code (keyval->code cl))) + (or s ag sag cl)))) + (unless 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) @@ -202,6 +214,7 @@ (define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) + (connect-key-release gtk) (connect-button-press gtk) (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) From 8a6417f3e6aadf02ee99c003c8c41ea2ad9557fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Sep 2010 05:05:19 -0600 Subject: [PATCH 189/462] more attempts to avoid flicker original commit: f13b569b751559a2be7ae39c690dff34ebd29fa7 --- collects/mred/private/wx/cocoa/canvas.rkt | 5 +++++ collects/mred/private/wx/cocoa/dc.rkt | 15 ++++++++++----- collects/mred/private/wx/cocoa/frame.rkt | 13 +++++++++---- collects/mred/private/wx/cocoa/platform.rkt | 2 -- collects/mred/private/wx/cocoa/procs.rkt | 2 -- collects/mred/private/wx/cocoa/window.rkt | 7 +++++-- collects/mred/private/wx/gtk/canvas.rkt | 3 +++ collects/mred/private/wx/gtk/platform.rkt | 2 -- collects/mred/private/wx/gtk/procs.rkt | 4 ---- collects/mred/private/wx/platform.rkt | 2 -- collects/mred/private/wx/win32/platform.rkt | 2 -- collects/mred/private/wx/win32/procs.rkt | 4 ---- collects/mred/private/wxme/editor-canvas.rkt | 4 +++- collects/mred/private/wxme/wx.rkt | 2 -- 14 files changed, 35 insertions(+), 32 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 5ba1e691..58a7b311 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -248,6 +248,11 @@ (not (send dc can-backing-flush?))) (do-on-paint #f #f))) + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread (queue-paint)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 2737d8a4..1925bd7c 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -57,6 +57,8 @@ (cairo_surface_destroy s) (set! s #f))))) +(define-local-member-name end-delay) + (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -94,10 +96,12 @@ (define/override (resume-flush) (atomically (set! suspend-count (sub1 suspend-count)) - (when (and (zero? suspend-count) req) - (cancel-flush-delay req) - (set! req #f)) - (super resume-flush))))) + (super resume-flush))) + + (define/public (end-delay) + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f))))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) @@ -124,4 +128,5 @@ (cairo_set_source cr s) (cairo_pattern_destroy s)) (cairo_destroy cr)))))) - (tellv ctx restoreGraphicsState))) + (tellv ctx restoreGraphicsState) + (send dc end-delay))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 98a89cac..c6f01ec3 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -262,15 +262,20 @@ "the eventspace hash been shutdown")) (when saved-child (if (eq? (current-thread) (eventspace-handler-thread es)) - (send saved-child paint-children) + (do-paint-children) (let ([s (make-semaphore)]) (queue-callback (lambda () - (when saved-child - (send saved-child paint-children)) + (do-paint-children) (semaphore-post s))) - (sync/timeout 0.2 s)))))) + (sync/timeout 1 s)))))) (direct-show on?)) + (define/private (do-paint-children) + (when saved-child + (send saved-child paint-children)) + (yield-refresh) + (try-to-sync-refresh)) + (define/public (destroy) (when child-sheet (send child-sheet destroy)) (direct-show #f)) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 345eefbe..79f16367 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -78,8 +78,6 @@ set-combo-box-font get-double-click-time run-printout - end-refresh-sequence - begin-refresh-sequence file-creator-and-type send-event set-executer diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 00744298..877d537a 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -30,8 +30,6 @@ set-executer send-event file-creator-and-type - begin-refresh-sequence - end-refresh-sequence run-printout get-double-click-time set-combo-box-font diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 7dbac31b..33ad82cc 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -130,7 +130,7 @@ (super-tell #:type _void keyDown: event))] [-a _void (keyUp: [_id event]) (unless (do-key-event wxb event self #f) - (super-tell #:type _void keyDown: event))] + (super-tell #:type _void keyUp: event))] [-a _void (insertText: [_NSString str]) (let ([cit (current-insert-text)]) (if cit @@ -455,7 +455,10 @@ ;; re-sync the display in case a stream of ;; events (e.g., key repeat) have a corersponding ;; stream of screen updates. - (void)) + (try-to-sync-refresh) + (let ([cocoa-win (get-cocoa-window)]) + (when cocoa-win + (tellv cocoa-win flushWindowIfNeeded)))) (define/public (dispatch-on-char/sync e) (pre-event-refresh) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 33bf7755..2c209f1c 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -373,6 +373,9 @@ (define/public (on-paint) (void)) + (define/public (begin-refresh-sequence) (void)) + (define/public (end-refresh-sequence) (void)) + (define/override (refresh) (queue-paint)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index c398f82b..2bc65319 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -78,8 +78,6 @@ set-combo-box-font get-double-click-time run-printout - end-refresh-sequence - begin-refresh-sequence file-creator-and-type send-event set-executer diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 23a7f8a0..c7e91cbd 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -34,8 +34,6 @@ set-executer send-event file-creator-and-type - begin-refresh-sequence - end-refresh-sequence run-printout get-double-click-time set-combo-box-font @@ -84,8 +82,6 @@ (case-lambda [(path cr ty) (void)] [(path) (values #"????" #"????")])) -(define (begin-refresh-sequence) (void)) -(define (end-refresh-sequence) (void)) (define-unimplemented run-printout) (define (get-double-click-time) 250) (define (set-combo-box-font f) (void)) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 69690c98..3f5842a5 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -56,8 +56,6 @@ set-combo-box-font get-double-click-time run-printout - end-refresh-sequence - begin-refresh-sequence file-creator-and-type send-event set-executer diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 9e8ccdfa..61d922b7 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -77,8 +77,6 @@ set-combo-box-font get-double-click-time run-printout - end-refresh-sequence - begin-refresh-sequence file-creator-and-type send-event set-executer diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 120851f6..844fbca4 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -24,8 +24,6 @@ set-executer send-event file-creator-and-type - begin-refresh-sequence - end-refresh-sequence run-printout get-double-click-time set-combo-box-font @@ -76,8 +74,6 @@ (define-unimplemented set-executer) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) -(define-unimplemented begin-refresh-sequence) -(define-unimplemented end-refresh-sequence) (define-unimplemented run-printout) (define-unimplemented get-double-click-time) (define-unimplemented set-combo-box-font) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index 9853ae4d..cb492ed0 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -159,7 +159,9 @@ get-scroll-range set-scroll-range is-shown-to-root? show-scrollbars - set-focus) + set-focus + begin-refresh-sequence + end-refresh-sequence) (define blink-timer #f) (define noloop? #f) diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index 1be64b3f..fd248acf 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -42,8 +42,6 @@ the-clipboard the-x-selection-clipboard get-double-click-threshold - begin-refresh-sequence - end-refresh-sequence begin-busy-cursor end-busy-cursor hide-cursor From ceddc9fbf58f1440e7158d56efe0cd2826a5d9b4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 05:53:29 -0600 Subject: [PATCH 190/462] another cocoa refresh repair original commit: 909ee0f32dc046f5d25338687146edca84278ab0 --- collects/mred/private/wx/cocoa/dc.rkt | 2 ++ collects/mred/private/wx/cocoa/window.rkt | 13 ------------- 2 files changed, 2 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 1925bd7c..bb375f78 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -23,6 +23,7 @@ (define _CGContextRef (_cpointer 'CGContextRef)) (define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) +(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) @@ -89,6 +90,7 @@ (define/override (suspend-flush) (atomically (when (zero? suspend-count) + (when req (cancel-flush-delay req)) (set! req (request-flush-delay (send canvas get-cocoa-window)))) (set! suspend-count (add1 suspend-count)) (super suspend-flush))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 33ad82cc..5709b1dc 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -449,19 +449,7 @@ ;; Called in Cocoa event-handling mode #f) - (define/private (pre-event-refresh) - ;; Since we break the connection between the - ;; Cocoa queue and event handling, we'd like to - ;; re-sync the display in case a stream of - ;; events (e.g., key repeat) have a corersponding - ;; stream of screen updates. - (try-to-sync-refresh) - (let ([cocoa-win (get-cocoa-window)]) - (when cocoa-win - (tellv cocoa-win flushWindowIfNeeded)))) - (define/public (dispatch-on-char/sync e) - (pre-event-refresh) (dispatch-on-char e #f)) (define/public (dispatch-on-char e just-pre?) (cond @@ -471,7 +459,6 @@ [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event/sync e) - (pre-event-refresh) (dispatch-on-event e #f)) (define/public (dispatch-on-event e just-pre?) (cond From f37b3304f2653d5aea51fb260c60a9d33c222663 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 07:26:53 -0600 Subject: [PATCH 191/462] fix text-drawing performance original commit: 0e64be35b7610d3e622f20dd121482b897581b91 --- collects/mred/private/wx/cocoa/canvas.rkt | 4 +++- collects/mred/private/wx/cocoa/window.rkt | 10 ++++++++++ collects/mred/private/wx/common/backing-dc.rkt | 5 +++-- collects/mred/private/wx/gtk/canvas.rkt | 4 +++- 4 files changed, 19 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 58a7b311..93bf8d54 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -223,15 +223,17 @@ (when pq (set-box! pq #f))) (set! paint-queued #f) (when (or (not b) (is-shown-to-root?)) - (send dc reset-backing-retained) ; start with a clean slate (send dc ensure-ready) + (send dc erase) ; start with a clean slate (let ([bg (get-canvas-background)]) (when bg (let ([old-bg (send dc get-background)]) (send dc set-background bg) (send dc clear) (send dc set-background old-bg)))) + (send dc suspend-flush) (on-paint) + (send dc resume-flush) (queue-backing-flush))) (when req (cancel-flush-delay req))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5709b1dc..39492e5b 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -449,7 +449,16 @@ ;; Called in Cocoa event-handling mode #f) + (define/private (pre-event-refresh key?) + ;; Since we break the connection between the + ;; Cocoa queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (try-to-sync-refresh)) + (define/public (dispatch-on-char/sync e) + (pre-event-refresh #t) (dispatch-on-char e #f)) (define/public (dispatch-on-char e just-pre?) (cond @@ -459,6 +468,7 @@ [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event/sync e) + (pre-event-refresh #f) (dispatch-on-event e #f)) (define/public (dispatch-on-event e just-pre?) (cond diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index b711207e..4c640897 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -32,7 +32,8 @@ (inherit call-with-cr-lock internal-get-bitmap internal-set-bitmap - reset-cr) + reset-cr + erase) (super-new) @@ -68,7 +69,7 @@ (define/public (reset-backing-retained [proc void]) (let ([cr retained-cr]) - (when cr + (when cr (let ([bm (internal-get-bitmap)]) (set! retained-cr #f) (internal-set-bitmap #f #t) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 2c209f1c..b8069171 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -349,15 +349,17 @@ (lambda () (set! paint-queued? #f) (set! now-drawing? #t) - (send dc reset-backing-retained) ; clean slate (send dc ensure-ready) + (send dc erase) ; clean slate (let ([bg (get-canvas-background)]) (when bg (let ([old-bg (send dc get-background)]) (send dc set-background bg) (send dc clear) (send dc set-background old-bg)))) + (send dc suspend-flush) (on-paint) + (send dc resume-flush) (set! now-drawing? #f) (when refresh-after-drawing? (set! refresh-after-drawing? #f) From d93d8e5dfcd5e6cb3a3ca8df64bea703ed177415 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 08:16:00 -0600 Subject: [PATCH 192/462] fix yet another refresh problem original commit: 6d8bb2cab4d9d0a4ec24cbf885c41e13c9771570 --- collects/mred/private/wx/cocoa/canvas.rkt | 2 +- collects/mred/private/wx/gtk/canvas.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 93bf8d54..6c4bb59d 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -223,6 +223,7 @@ (when pq (set-box! pq #f))) (set! paint-queued #f) (when (or (not b) (is-shown-to-root?)) + (send dc suspend-flush) (send dc ensure-ready) (send dc erase) ; start with a clean slate (let ([bg (get-canvas-background)]) @@ -231,7 +232,6 @@ (send dc set-background bg) (send dc clear) (send dc set-background old-bg)))) - (send dc suspend-flush) (on-paint) (send dc resume-flush) (queue-backing-flush))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index b8069171..748bd5e7 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -349,6 +349,7 @@ (lambda () (set! paint-queued? #f) (set! now-drawing? #t) + (send dc suspend-flush) (send dc ensure-ready) (send dc erase) ; clean slate (let ([bg (get-canvas-background)]) @@ -357,7 +358,6 @@ (send dc set-background bg) (send dc clear) (send dc set-background old-bg)))) - (send dc suspend-flush) (on-paint) (send dc resume-flush) (set! now-drawing? #f) From 4e23681799fe70886e63fd872ece648c4d18d952 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 14:03:29 -0600 Subject: [PATCH 193/462] still again yet another refinement to cocoa refresh original commit: 748115fe91205e5df2128d8ea4f12b7ec8fa5076 --- collects/mred/private/wx/cocoa/canvas.rkt | 1 + collects/mred/private/wx/cocoa/cg.rkt | 20 ++++++++++++++++++ collects/mred/private/wx/cocoa/dc.rkt | 25 +++-------------------- collects/mred/private/wx/cocoa/window.rkt | 6 +++++- collects/mred/private/wx/common/queue.rkt | 19 +++++++++-------- 5 files changed, 40 insertions(+), 31 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/cg.rkt diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 6c4bb59d..432d8847 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -10,6 +10,7 @@ "types.rkt" "window.rkt" "dc.rkt" + "cg.rkt" "queue.rkt" "item.rkt" "../common/backing-dc.rkt" diff --git a/collects/mred/private/wx/cocoa/cg.rkt b/collects/mred/private/wx/cocoa/cg.rkt new file mode 100644 index 00000000..95bd5da5 --- /dev/null +++ b/collects/mred/private/wx/cocoa/cg.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "types.rkt" + "utils.rkt") + +(provide (all-defined-out)) + +(define _CGContextRef (_cpointer 'CGContextRef)) +(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) +(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) +(define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) +(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) +(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index bb375f78..c8986fc4 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -9,30 +9,11 @@ "window.rkt" "../../lock.rkt" "../common/queue.rkt" - "../common/backing-dc.rkt") + "../common/backing-dc.rkt" + "cg.rkt") (provide dc% - do-backing-flush - - _CGContextRef - CGContextSetRGBFillColor - CGContextFillRect - CGContextAddRect - CGContextStrokePath - CGContextAddLines) - -(define _CGContextRef (_cpointer 'CGContextRef)) -(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) -(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) -(define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) -(define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) -(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) -(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) -(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) -(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) -(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) -(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) -(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) + do-backing-flush) (define quartz-bitmap% (class object% diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 39492e5b..e2a3a0a3 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -455,7 +455,11 @@ ;; re-sync the display in case a stream of ;; events (e.g., key repeat) have a corresponding ;; stream of screen updates. - (try-to-sync-refresh)) + (try-to-sync-refresh) + (let ([cocoa-win (get-cocoa-window)]) + (when cocoa-win + (tellv cocoa-win displayIfNeeded) + (tellv cocoa-win flushWindowIfNeeded)))) (define/public (dispatch-on-char/sync e) (pre-event-refresh #t) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 6f524ac0..27a25c42 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -177,8 +177,8 @@ (make-eventspace th (let ([count 0]) (let ([lo (mcons #f #f)] - [med (mcons #f #f)] [refresh (mcons #f #f)] + [med (mcons #f #f)] [hi (mcons #f #f)] [timer (box '())] [timer-counter 0] @@ -226,8 +226,8 @@ (let ([val (cdr v)]) (case (car v) [(lo) (enqueue val lo)] - [(med) (enqueue val med)] [(refresh) (enqueue val refresh)] + [(med) (enqueue val med)] [(hi) (enqueue val hi)] [(timer-add) (set! timer-counter (add1 timer-counter)) @@ -275,8 +275,8 @@ (lambda (_) #f)) (or (first hi) (timer-first-ready timer) - (first med) (first refresh) + (first med) (first lo) (timer-first-wait timer) ;; nothing else ready... @@ -374,11 +374,14 @@ (define yield-refresh (lambda () (let ([e (current-eventspace)]) - (when (eq? (current-thread) (eventspace-handler-thread e)) - (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))]) - (when v - (handle-event v) - (yield-refresh))))))) + (and (eq? (current-thread) (eventspace-handler-thread e)) + (let loop ([result #f]) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))]) + (if v + (begin + (handle-event v) + (loop #t)) + result))))))) (define event-dispatch-handler (make-parameter void)) (define (main-eventspace? e) From af897378f604838eec22645a0a4dd7e967bbead7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2010 16:42:28 -0600 Subject: [PATCH 194/462] mac creator and type support original commit: fa446f0187a66d0b5807d212e86ce369ffa1b13e --- collects/mred/private/wx/cocoa/finfo.rkt | 149 +++++++++++++++++++++++ collects/mred/private/wx/cocoa/procs.rkt | 2 +- 2 files changed, 150 insertions(+), 1 deletion(-) create mode 100644 collects/mred/private/wx/cocoa/finfo.rkt diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt new file mode 100644 index 00000000..937f808a --- /dev/null +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -0,0 +1,149 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "utils.rkt" + "types.rkt") + +(provide file-creator-and-type) + +(define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices"))) + +(define-ffi-definer define-coreserv coreserv-lib) + +(define kFSCatInfoFinderInfo #x00000800) +(define _FSCatalogInfoBitmap _uint32) + +(define _FSVolumeRefNum _int16) + +(define-cstruct _UTCDateTime + #:alignment 2 + ([highSeconds _uint16] + [lowSeconds _uint32] + [fraction _uint16])) + +(define-cstruct _Point + ([v _short] + [h _short])) + +(define _OSType _uint32) + +(define-cstruct _FileInfo + #:alignment 2 + ([fileType _OSType] + [fileCreator _OSType] + [finderFlags _uint16] + [location _Point] + [reservedField _uint16])) + +(define-cstruct _FSPermissionInfo + #:alignment 2 + ([userID _uint32] + [groupID _uint32] + [word _uint32] + [fileSec _pointer])) + +(define-cstruct _FSCatalogInfo + #:alignment 2 + ([nodeFlags _uint16] + [volume _FSVolumeRefNum] + [parentDirID _uint32] + [nodeID _uint32] + [sharingFlags _uint8] + [userPrivileges _uint8] + [reserved1 _uint8] + [reserved2 _uint8] + [createDate _UTCDateTime] + [contentModDate _UTCDateTime] + [attributeModDate _UTCDateTime] + [accessDate _UTCDateTime] + [backupDate _UTCDateTime] + [permissions _FSPermissionInfo] + [finderInfo _FileInfo] + ;; .... 144 or 148 bytes total + )) + +(define _FSRef _pointer) ; 80 bytes + +(define _OSStatus _sint32) + +(define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus)) + +(define-coreserv FSGetCatalogInfo + (_fun _FSRef + _FSCatalogInfoBitmap + _FSCatalogInfo-pointer + _pointer ; outname, #f is ok + _pointer ; fsSpec, #f is ok + _pointer ; parentRef, #f is ok + -> _OSStatus)) + +(define-coreserv FSSetCatalogInfo + (_fun _FSRef + _FSCatalogInfoBitmap + _FSCatalogInfo-pointer + -> _OSStatus)) + +(define (path->fsref s) + (let ([fs (malloc 80)]) + (let ([r (FSPathMakeRef s fs)]) + (unless (zero? r) + (error 'file-creator-and-type "could not access file (~a): ~v" + r + s))) + fs)) + +(define (int->str v) + (bytes (arithmetic-shift (bitwise-and v #xFF000000) -24) + (arithmetic-shift (bitwise-and v #xFF0000) -16) + (arithmetic-shift (bitwise-and v #xFF00) -8) + (bitwise-and v #xFF))) + +(define (str->int v) + (bitwise-ior (arithmetic-shift (bytes-ref v 0) 24) + (arithmetic-shift (bytes-ref v 1) 16) + (arithmetic-shift (bytes-ref v 2) 8) + (bytes-ref v 3))) + + +(define (get-info v fs path) + (let ([r (FSGetCatalogInfo fs + kFSCatInfoFinderInfo + v + #f #f #f)]) + (unless (zero? r) + (error 'file-creator-and-file "lookup failed (~a): ~e" + r + path)))) + +(define file-creator-and-type + (case-lambda + [(path) + (unless (path-string? path) + (raise-type-error 'file-creator-and-type "path string" path)) + (let ([info (let ([fs (path->fsref path)] + [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + (get-info v fs path) + (FSCatalogInfo-finderInfo v))]) + (values (int->str (FileInfo-fileCreator info)) + (int->str (FileInfo-fileType info))))] + [(path creator type) + (unless (path-string? path) + (raise-type-error 'file-creator-and-type "path string" path)) + (unless (and (bytes? creator) (= 4 (bytes-length creator))) + (raise-type-error 'file-creator-and-type "bytes string of length 4" creator)) + (unless (and (bytes? type) (= 4 (bytes-length type))) + (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) + (let ([fs (path->fsref path)] + [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + (let ([info (FSCatalogInfo-finderInfo v)]) + (get-info v fs path) + (set-FileInfo-fileCreator! info (str->int creator)) + (set-FileInfo-fileType! info (str->int type))) + (let ([r (FSSetCatalogInfo fs + kFSCatInfoFinderInfo + v)]) + (unless (zero? r) + (error 'file-creator-and-file "change failed (~a): ~e" + r + path)))) + (void)])) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 877d537a..2f44863f 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -7,6 +7,7 @@ "utils.rkt" "types.rkt" "frame.rkt" + "finfo.rkt" ; file-creator-and-type "../../lock.rkt" "../common/handlers.rkt") @@ -77,7 +78,6 @@ (define (set-executer proc) (void)) (define-unimplemented send-event) -(define-unimplemented file-creator-and-type) (define (begin-refresh-sequence) (void)) (define (end-refresh-sequence) (void)) (define-unimplemented run-printout) From 8b5e617253d9474d52bad223e0c9fb84a1495f70 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Sep 2010 13:26:53 -0600 Subject: [PATCH 195/462] update for new #:alignment placement original commit: 3e35c7c27319fddba2f973f7bc061ecd38b71186 --- collects/mred/private/wx/cocoa/finfo.rkt | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index 937f808a..4d841bbc 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -16,10 +16,10 @@ (define _FSVolumeRefNum _int16) (define-cstruct _UTCDateTime - #:alignment 2 ([highSeconds _uint16] [lowSeconds _uint32] - [fraction _uint16])) + [fraction _uint16]) + #:alignment 2) (define-cstruct _Point ([v _short] @@ -28,22 +28,21 @@ (define _OSType _uint32) (define-cstruct _FileInfo - #:alignment 2 ([fileType _OSType] [fileCreator _OSType] [finderFlags _uint16] [location _Point] - [reservedField _uint16])) + [reservedField _uint16]) + #:alignment 2) (define-cstruct _FSPermissionInfo - #:alignment 2 ([userID _uint32] [groupID _uint32] [word _uint32] - [fileSec _pointer])) + [fileSec _pointer]) + #:alignment 2) (define-cstruct _FSCatalogInfo - #:alignment 2 ([nodeFlags _uint16] [volume _FSVolumeRefNum] [parentDirID _uint32] @@ -60,7 +59,8 @@ [permissions _FSPermissionInfo] [finderInfo _FileInfo] ;; .... 144 or 148 bytes total - )) + ) + #:alignment 2) (define _FSRef _pointer) ; 80 bytes From ba7d6d7cc13da6a5d2683e4a6bd74eb13f910f2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Sep 2010 15:15:42 -0600 Subject: [PATCH 196/462] cocoa mouse event and cursor fixes original commit: c3fa1f01e8babe7355ba3a5a063f96091fcb7c74 --- collects/mred/private/wx/cocoa/frame.rkt | 7 ++ collects/mred/private/wx/cocoa/window.rkt | 96 +++++++++++++++++------ collects/tests/gracket/showkey.rkt | 53 ++++++------- 3 files changed, 105 insertions(+), 51 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index c6f01ec3..3dbec1b2 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -345,6 +345,13 @@ (install-wait-cursor) (uninstall-wait-cursor)))) + (define/override (start-no-cursor-rects) + (tell cocoa disableCursorRects)) + + (define/override (end-no-cursor-rects) + (unless (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tell cocoa enableCursorRects))) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index e2a3a0a3..dab0c839 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -99,12 +99,19 @@ (loop (tell hit superview))))))] [-a _BOOL (doMouseMoved: [_id event]) ;; called by mouseMoved: - (do-mouse-event wxb event 'motion #f #f #f)] + (and + ;; Make sure we're in the right eventspace: + (let ([wx (->wx wxb)]) + (and wx + (eq? (current-eventspace) + (send wx get-eventspace)))) + ;; Right event space, so handle the event: + (do-mouse-event wxb event 'motion #f #f #f))] [-a _void (mouseEntered: [_id event]) - (unless (do-mouse-event wxb event 'enter #f #f #f) + (unless (do-mouse-event wxb event 'enter 'check 'check 'check) (super-tell #:type _void mouseEntered: event))] [-a _void (mouseExited: [_id event]) - (unless (do-mouse-event wxb event 'leave #f #f #f) + (unless (do-mouse-event wxb event 'leave 'check 'check 'check) (super-tell #:type _void mouseExited: event))] [-a _void (rightMouseDown: [_id event]) (unless (do-mouse-event wxb event 'right-down #f #f #t) @@ -249,27 +256,46 @@ [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)]) (let-values ([(x y) (send wx window-point-to-view pos)] - [(control-down) (bit? modifiers NSControlKeyMask)]) - (let ([m (new mouse-event% - [event-type (if control-down ctl-kind kind)] - [left-down (and l? (not control-down))] - [middle-down m?] - [right-down (or r? (and l? control-down))] - [x (->long x)] - [y (->long y)] - [shift-down (bit? modifiers NSShiftKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx definitely-wants-event? m) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event/sync m))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))))))) + [(control-down) (bit? modifiers NSControlKeyMask)] + [(l?) (if (eq? l? 'check) + (send wx get-last-left-button) + l?)] + [(m?) (if (eq? m? 'check) + (send wx get-last-middle-button) + m?)] + [(r?) (if (eq? r? 'check) + (send wx get-last-right-button) + r?)]) + (let ([l? (and l? (not control-down))] + [r? (or r? (and l? control-down))]) + (send wx set-last-buttons l? m? r?) + (let ([m (new mouse-event% + [event-type (if control-down ctl-kind kind)] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (cond + [(send m dragging?) (void)] + [(send m button-down?) + (send wx set-sticky-cursor) + (send wx start-no-cursor-rects)] + [(or l? m? r?) (void)] + [else (send wx end-no-cursor-rects)]) + (if (send wx definitely-wants-event? m) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event/sync m))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t))))))))) (define window% (class object% @@ -507,6 +533,26 @@ (define/public (on-event m) (void)) (define/public (on-size x y) (void)) + (define last-l? #f) + (define last-m? #f) + (define last-r? #f) + (define/public (set-last-buttons l? m? r?) + (set! last-l? l?) + (set! last-m? m?) + (set! last-r? r?)) + (define/public (get-last-left-button) last-l?) + (define/public (get-last-middle-button) last-m?) + (define/public (get-last-right-button) last-r?) + + (define/public (set-sticky-cursor) + (set! sticky-cursor? #t)) + + (define/public (start-no-cursor-rects) + (send (get-parent) start-no-cursor-rects)) + (define/public (end-no-cursor-rects) + (set! sticky-cursor? #f) + (send (get-parent) end-no-cursor-rects)) + (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) @@ -543,6 +589,7 @@ (def/public-unimplemented fit) (define cursor-handle #f) + (define sticky-cursor? #f) (define/public (set-cursor c) (let ([h (if c (send (send c get-driver) get-handle) @@ -550,6 +597,7 @@ (unless (eq? h cursor-handle) (atomically (set! cursor-handle h) + (when sticky-cursor? (tellv h set)) (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content)))))) (define/public (reset-cursor-rects) ;; called in event-pump thread diff --git a/collects/tests/gracket/showkey.rkt b/collects/tests/gracket/showkey.rkt index 124c4323..9f7705ec 100644 --- a/collects/tests/gracket/showkey.rkt +++ b/collects/tests/gracket/showkey.rkt @@ -16,33 +16,32 @@ (class canvas% (super-new) (define/override (on-event ev) - (lambda (ev) - (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" - (es-check) - iter - (send ev get-event-type) - (send ev get-x) - (send ev get-y) - (if (send ev get-meta-down) " META" "") - (if (send ev get-control-down) " CTL" "") - (if (send ev get-alt-down) " ALT" "") - (if (send ev get-shift-down) " SHIFT" "") - (if (send ev get-caps-down) " CAPS" "") - (if (send ev get-left-down) " LEFT" "") - (if (send ev get-middle-down) " MIDDLE" "") - (if (send ev get-right-down) " RIGHT" "") - (if (send ev dragging?) - " dragging" - "") - (if (send ev moving?) - " moving" - "") - (if (send ev entering?) - " entering" - "") - (if (send ev leaving?) - " leaving" - "")))) + (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" + (es-check) + iter + (send ev get-event-type) + (send ev get-x) + (send ev get-y) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" "") + (if (send ev get-left-down) " LEFT" "") + (if (send ev get-middle-down) " MIDDLE" "") + (if (send ev get-right-down) " RIGHT" "") + (if (send ev dragging?) + " dragging" + "") + (if (send ev moving?) + " moving" + "") + (if (send ev entering?) + " entering" + "") + (if (send ev leaving?) + " leaving" + ""))) (define/override (on-char ev) (set! iter (add1 iter)) (printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n" From 22d6199bc18c9c0a917565c8230874f2b0462fe0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Sep 2010 21:01:53 -0600 Subject: [PATCH 197/462] cocoa file dialog original commit: 5117d094731e6fac7fb14d10e65fdcbae8d5f5a3 --- collects/mred/private/filedialog.rkt | 50 ++++------ collects/mred/private/wx/cocoa/filedialog.rkt | 95 +++++++++++++++++++ collects/mred/private/wx/cocoa/frame.rkt | 11 ++- collects/mred/private/wx/cocoa/procs.rkt | 3 +- collects/mred/private/wx/common/queue.rkt | 2 +- 5 files changed, 121 insertions(+), 40 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/filedialog.rkt diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 026dfe65..a6f24eb0 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -17,17 +17,6 @@ put-file get-directory) - (define (files->list s) - (let ([s (open-input-bytes s)]) - (let loop () - (let ([n (read s)]) - (if (eof-object? n) - null - (begin - (read-byte s) ; drop space - (cons (read-bytes n s) - (loop)))))))) - (define (mk-file-selector who put? multi? dir?) (lambda (message parent directory filename extension style filters) ;; Calls from C++ have wrong kind of window: @@ -52,9 +41,7 @@ (raise-type-error who "list of 2-string lists" filters)) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) - (if (or std? - ;; no Cocoa dialog, yet: - (eq? (system-type) 'macosx)) + (if std? (send (new path-dialog% [put? put?] [dir? dir?] @@ -68,25 +55,22 @@ [dir? #f] [else filters])]) run) - (let ([s (wx:file-selector - message directory filename extension - ;; file types: - filters - #; - (apply string-append - (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) - filters)) - ;; style: - (cons (cond [dir? 'dir] - [put? 'put] - [multi? 'multi] - [else 'get]) - style) - ;; parent: - (and parent (mred->wx parent)))]) - (if (and multi? s) - (map bytes->path (files->list (path->bytes s))) - s)))))) + (wx:file-selector + message directory filename extension + ;; file types: + filters + #; + (apply string-append + (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) + filters)) + ;; style: + (cons (cond [dir? 'dir] + [put? 'put] + [multi? 'multi] + [else 'get]) + style) + ;; parent: + (and parent (mred->wx parent))))))) (define default-filters '(("Any" "*.*"))) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt new file mode 100644 index 00000000..1d19c677 --- /dev/null +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/path + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "queue.rkt" + "frame.rkt") + +(provide file-selector) + +(import-class NSOpenPanel NSSavePanel NSURL NSArray) + +(define (nsurl->string url) + (string->path (tell #:type _NSString url path))) + +(define (file-selector message directory filename + extension + filters style parent) + (let ([ns (if (memq 'put style) + (tell NSSavePanel savePanel) + (tell NSOpenPanel openPanel))] + [parent (and parent + (not (send parent get-sheet)) + parent)]) + ;; Why? This looks like a leak, but we get crashes + ;; without it. + (retain ns) + + (let ([extensions (append + (if extension (list extension) null) + (if (memq 'packages style) (list "app") null) + (for/list ([e (in-list filters)] + #:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e)) + (not (equal? (cadr e) "*.*")))) + (car (regexp-match #rx"[^.]+$" (cadr e)))))]) + (unless (null? extensions) + (when (memq 'put style) + (tellv ns setCanSelectHiddenExtension: #:type _BOOL #t)) + (let ([a (tell NSArray + arrayWithObjects: #:type (_list i _NSString) extensions + count: #:type _NSUInteger (length extensions))]) + (tellv ns setAllowedFileTypes: a)))) + (when (not (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL #f)) + + (cond + [(memq 'multi style) + (tellv ns setAllowsMultipleSelection: #:type _BOOL #t)] + [(memq 'dir style) + (tellv ns setCanChooseDirectories: #:type _BOOL #t) + (tellv ns setCanChooseFiles: #:type _BOOL #f)]) + + (when message + (tellv ns setMessage: #:type _NSString message)) + (when directory + (tellv ns setDirectoryURL: (tell NSURL + fileURLWithPath: #:type _NSString (if (string? directory) + directory + (path->string directory)) + isDirectory: #:type _BOOL #t))) + (when filename + (tellv ns setNameFieldStringValue: #:type _NSString (path->string + (file-name-from-path filename)))) + + (when (memq 'enter-packages style) + (tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t)) + + (let ([result + ;; We run the file dialog completely modally --- shutting out + ;; all other eventspaces and threads. It would be nice to improve + ;; on this, but it's good enough. + (atomically + (let ([front (get-front)]) + (when parent + (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) + completionHandler: #f)) + (begin0 + (tell #:type _NSInteger ns runModal) + (when parent (tell app endSheet: ns)) + (when front (tellv (send front get-cocoa-window) + makeKeyAndOrderFront: #f)))))]) + (if (zero? result) + #f + (if (memq 'multi style) + (let ([urls (tell ns URLs)]) + (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) + (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) + (let ([url (tell ns URL)]) + (nsurl->string url))))))) + diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3dbec1b2..a82b3eef 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require ffi/objc - scheme/foreign +(require ffi/unsafe/objc + ffi/unsafe scheme/class "pool.rkt" "utils.rkt" @@ -13,11 +13,10 @@ "../../syntax.rkt" "../common/queue.rkt" "../../lock.rkt") -(unsafe!) -(objc-unsafe!) (provide frame% - location->window) + location->window + get-front) ;; ---------------------------------------- @@ -26,6 +25,8 @@ (define front #f) +(define (get-front) front) + (define empty-mb (new menu-bar%)) (define root-fake-frame #f) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 2f44863f..a03daccc 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -8,6 +8,7 @@ "types.rkt" "frame.rkt" "finfo.rkt" ; file-creator-and-type + "filedialog.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -110,7 +111,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) -(define-unimplemented file-selector) (define (id-to-menu-item id) id) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) @@ -129,6 +129,7 @@ colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] [as-color (lambda (v) (inexact->exact (floor (* 255.0 v))))]) + (unless hi (error "selection background color lookup failed!")) (make-object color% (as-color (tell #:type _CGFloat hi redComponent)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 27a25c42..0f0672e6 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -412,7 +412,7 @@ (lambda (k v) k))) (define (other-modal? win) - ;; called in event-pump thread + ;; called in atmoic mode in eventspace's thread (let loop ([frames (get-top-level-windows)]) (and (pair? frames) (let ([status (send (car frames) frame-relative-dialog-status win)]) From eb677e9efb2ca471fe7b1e5f23cf9ade716dace6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Sep 2010 21:14:12 -0600 Subject: [PATCH 198/462] cocoa allocation repairs original commit: 227300dc94eb0c97f69668f7dcfc6fbffbc3bb02 --- collects/mred/private/wx/cocoa/filedialog.rkt | 26 +++++++++---------- collects/mred/private/wx/cocoa/procs.rkt | 22 +++++++++------- collects/mred/private/wx/cocoa/utils.rkt | 6 +++++ 3 files changed, 31 insertions(+), 23 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 1d19c677..c2bfc8ae 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -19,15 +19,13 @@ (define (file-selector message directory filename extension filters style parent) - (let ([ns (if (memq 'put style) + (let ([ns (as-objc-allocation-with-retain + (if (memq 'put style) (tell NSSavePanel savePanel) - (tell NSOpenPanel openPanel))] + (tell NSOpenPanel openPanel)))] [parent (and parent (not (send parent get-sheet)) parent)]) - ;; Why? This looks like a leak, but we get crashes - ;; without it. - (retain ns) (let ([extensions (append (if extension (list extension) null) @@ -84,12 +82,14 @@ (when parent (tell app endSheet: ns)) (when front (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))]) - (if (zero? result) - #f - (if (memq 'multi style) - (let ([urls (tell ns URLs)]) - (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) - (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) - (let ([url (tell ns URL)]) - (nsurl->string url))))))) + (begin0 + (if (zero? result) + #f + (if (memq 'multi style) + (let ([urls (tell ns URLs)]) + (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) + (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) + (let ([url (tell ns URL)]) + (nsurl->string url)))) + (release ns))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index a03daccc..374a89a7 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -125,18 +125,20 @@ (define-cocoa NSCalibratedRGBColorSpace _id) (define (get-highlight-background-color) - (let ([hi (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] + (let ([hi (as-objc-allocation-with-retain + (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSCalibratedRGBColorSpace))] [as-color (lambda (v) (inexact->exact (floor (* 255.0 v))))]) - (unless hi (error "selection background color lookup failed!")) - (make-object color% - (as-color - (tell #:type _CGFloat hi redComponent)) - (as-color - (tell #:type _CGFloat hi greenComponent)) - (as-color - (tell #:type _CGFloat hi blueComponent))))) + (begin0 + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))) + (release hi)))) (define (get-highlight-text-color) #f) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 37c1712c..bc40b320 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -13,6 +13,7 @@ define-appkit define-mz as-objc-allocation + as-objc-allocation-with-retain retain release with-autorelease clean-menu-label @@ -37,6 +38,11 @@ (define-syntax-rule (as-objc-allocation expr) ((objc-allocator (lambda () expr)))) +(define-syntax-rule (as-objc-allocation-with-retain expr) + ((objc-allocator (lambda () (let ([v expr]) + (tellv v retain) + v))))) + (define release ((deallocator) objc-delete)) (define retain ((retainer release car) (lambda (obj) From 1c4ee63662c728e1f014eabe6a779ba6df41234f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 09:22:40 -0600 Subject: [PATCH 199/462] collecting-blit for cocoa original commit: 0691f0491e72728cba7769c2b2a9502bbd926d8b --- collects/mred/private/gdi.rkt | 10 +++ collects/mred/private/wx/cocoa/canvas.rkt | 95 ++++++++++++++++++++++- collects/mred/private/wx/cocoa/frame.rkt | 10 +++ collects/mred/private/wx/cocoa/gc.rkt | 26 +++++++ collects/mred/private/wx/cocoa/panel.rkt | 4 + collects/mred/private/wx/cocoa/procs.rkt | 6 +- collects/mred/private/wx/cocoa/window.rkt | 20 +++-- 7 files changed, 159 insertions(+), 12 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/gc.rkt diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 15b66935..659e38ef 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -32,6 +32,16 @@ [(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)] [(canvas x y w h on off on-x on-y off-x off-y) (check-instance 'register-collecting-blit canvas% 'canvas% #f canvas) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit y) + ((check-bounded-integer 0 10000 #f) 'register-collecting-blit w) + ((check-bounded-integer 0 10000 #f) 'register-collecting-blit h) + (check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f on) + (check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f off) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-y) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-y) (wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)])) (define unregister-collecting-blit diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 432d8847..3be04ed7 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -13,6 +13,8 @@ "cg.rkt" "queue.rkt" "item.rkt" + "gc.rkt" + "image.rkt" "../common/backing-dc.rkt" "../common/event.rkt" "../common/queue.rkt" @@ -24,10 +26,14 @@ ;; ---------------------------------------- -(import-class NSView NSGraphicsContext NSScroller NSComboBox) +(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow NSImageView) (import-protocol NSComboBoxDelegate) +(define NSWindowAbove 1) + +(define o (current-error-port)) + ;; Called when a canvas has no backing store ready (define (clear-background wxb) (let ([wx (->wx wxb)]) @@ -174,7 +180,8 @@ on-size register-as-child get-size get-position - set-focus) + set-focus + client-to-screen) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) @@ -336,7 +343,17 @@ (super show on?) (fix-dc)) + (define/override (hide-children) + (super hide-children) + (suspend-all-reg-blits)) + + (define/override (show-children) + (super show-children) + (resume-all-reg-blits)) + (define/private (do-set-size x y w h) + (when (pair? blits) + (atomically (suspend-all-reg-blits))) (super set-size x y w h) (when tr (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) @@ -369,6 +386,9 @@ (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) x-sb-margin x-sb-margin)) scroll-width)))) + (when (and (pair? blits) + (is-shown-to-root?)) + (atomically (resume-all-reg-blits))) (fix-dc) (when auto-scroll? (reset-auto-scroll 0 0)) @@ -708,4 +728,73 @@ (define/public (get-virtual-size xb yb) (get-client-size xb yb) (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))))) + (when virtual-height (set-box! yb virtual-height))) + + (define blits null) + (define reg-blits null) + + (define/private (suspend-all-reg-blits) + (let ([cocoa-win (get-cocoa-window)]) + (for ([r (in-list reg-blits)]) + (tellv cocoa-win removeChildWindow: (car r)) + (release (car r)) + (scheme_remove_gc_callback (cdr r)))) + (set! reg-blits null)) + + (define/public (resume-all-reg-blits) + (unless (pair? reg-blits) + (when (pair? blits) + (set! reg-blits + (for/list ([b (in-list blits)]) + (let-values ([(x y w h img) (apply values b)]) + (register-one-blit x y w h img))))))) + + (define/private (register-one-blit x y w h img) + (let ([xb (box x)] + [yb (box y)]) + (client-to-screen xb yb #f) + (let* ([cocoa-win (get-cocoa-window)]) + (atomically + (let ([win (as-objc-allocation + (tell (tell NSWindow alloc) + initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) + (- (unbox yb) + h)) + (make-NSSize w h)) + styleMask: #:type _int NSBorderlessWindowMask + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))] + [iv (tell (tell NSImageView alloc) init)]) + (tellv iv setImage: img) + (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))) + (tellv (tell win contentView) addSubview: iv) + (tellv win setAlphaValue: #:type _CGFloat 0.0) + (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) + (tellv iv release) + (let ([r (scheme_add_gc_callback + (make-gc-action-desc win (selector setAlphaValue:) 1.0) + (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) + (cons win r))))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))]) + (let ([img (bitmap->image on)]) + (atomically + (set! blits (cons (list x y w h img) blits)) + (when (is-shown-to-root?) + (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (suspend-all-reg-blits) + (set! blits null))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index a82b3eef..457035ff 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -204,6 +204,9 @@ (eq? front this)) (set! front #f) (send empty-mb install)) + (if on? + (show-children) + (hide-children)) (if on? (begin (when is-a-dialog? @@ -281,6 +284,13 @@ (when child-sheet (send child-sheet destroy)) (direct-show #f)) + (define/override (hide-children) + (when saved-child + (send saved-child hide-children))) + (define/override (show-children) + (when saved-child + (send saved-child show-children))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) diff --git a/collects/mred/private/wx/cocoa/gc.rkt b/collects/mred/private/wx/cocoa/gc.rkt new file mode 100644 index 00000000..b582a48a --- /dev/null +++ b/collects/mred/private/wx/cocoa/gc.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt") + +(provide scheme_add_gc_callback + scheme_remove_gc_callback + make-gc-action-desc) + +(define objc-lib (ffi-lib "libobjc")) + +(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer)) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define (make-gc-action-desc win sel val) + (vector + (vector (if (= (ctype-sizeof _CGFloat) 4) + 'ptr_ptr_float->void + 'ptr_ptr_double->void) + msg-send-proc + win + sel + val))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 3837042f..67ced261 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -37,6 +37,10 @@ (define/override (hide-children) (for ([child (in-list children)]) (send child hide-children))) + + (define/override (show-children) + (for ([child (in-list children)]) + (send child show-children))) (define/override (paint-children) (for ([child (in-list children)]) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 374a89a7..90e394c7 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -68,8 +68,10 @@ (define-unimplemented play-sound) (define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) -(define (register-collecting-blit . args) (void)) -(define (unregister-collecting-blit . args) (void)) +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [x #f]) #f) (define-unimplemented in-atomic-region) (define (set-menu-tester proc) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index dab0c839..9ff5161c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -332,6 +332,8 @@ (define/public (hide-children) (is-responder this #f) (focus-is-on #f)) + (define/public (show-children) + (void)) (define/public (fix-dc) (void)) (define/public (paint-children) @@ -364,11 +366,13 @@ (tellv (send parent get-cocoa-content) addSubview: cocoa) (with-autorelease (tellv cocoa removeFromSuperview))) - (set! is-on? (and on? #t)))) - (maybe-register-as-child parent on?) - (unless on? - (hide-children) - (is-responder this #f))) + (set! is-on? (and on? #t)) + (maybe-register-as-child parent on?) + (if on? + (show-children) + (begin + (hide-children) + (is-responder this #f)))))) (define/public (maybe-register-as-child parent on?) ;; override this to call register-as-child if the window ;; can have the focus or otherwise needs show-state notifications. @@ -575,14 +579,16 @@ (set-box! xb (inexact->exact (floor (NSPoint-x p)))) (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) - (define/public (client-to-screen xb yb) + (define/public (client-to-screen xb yb [flip-y? #t]) (let* ([p (tell #:type _NSPoint (get-cocoa-window) convertBaseToScreen: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-content) convertPointToBase: #:type _NSPoint (make-NSPoint (unbox xb) (flip-client (unbox yb)))))]) - (let ([new-y (send (get-wx-window) flip-screen (NSPoint-y p))]) + (let ([new-y (if flip-y? + (send (get-wx-window) flip-screen (NSPoint-y p)) + (NSPoint-y p))]) (set-box! xb (inexact->exact (floor (NSPoint-x p)))) (set-box! yb (inexact->exact (floor new-y)))))) From e6693986f24b9f8652c29195c45de4853ab74a99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 10:23:19 -0600 Subject: [PATCH 200/462] fix key-event problem and implement mouse wheel for Cocoa original commit: 8da4bbd52ddf6e42866cb5b338efc5048236593a --- collects/mred/private/wx/cocoa/window.rkt | 106 ++++++++++-------- collects/mred/private/wx/gtk/window.rkt | 7 +- .../scribblings/gui/key-event-class.scrbl | 7 +- 3 files changed, 68 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 9ff5161c..28deb6d7 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -131,12 +131,17 @@ [-a _void (otherMouseDragged: [_id event]) (unless (do-mouse-event wxb event 'motion #f #t #f) (super-tell #:type _void otherMouseDragged: event))] + + [-a _void (scrollWheel: [_id event]) + (unless (and (not (zero? (tell #:type _CGFloat event deltaY))) + (do-key-event wxb event self #f #t)) + (super-tell #:type _void scrollWheel: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event self #t) + (unless (do-key-event wxb event self #t #f) (super-tell #:type _void keyDown: event))] [-a _void (keyUp: [_id event]) - (unless (do-key-event wxb event self #f) + (unless (do-key-event wxb event self #f #f) (super-tell #:type _void keyUp: event))] [-a _void (insertText: [_NSString str]) (let ([cit (current-insert-text)]) @@ -177,43 +182,51 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event self down?) +(define (do-key-event wxb event self down? wheel?) (let ([wx (->wx wxb)]) (and wx (let ([inserted-text (box #f)]) - ;; Calling `interpretKeyEvents:' allows key combinations to be - ;; handled, such as option-e followed by e to produce é. The - ;; call to `interpretKeyEvents:' typically calls `insertText:', - ;; so we set `current-insert-text' to tell `insertText:' to just - ;; give us back the text in the parameter. For now, we ignore the - ;; text and handle the event as usual, though probably we should - ;; be doing something with it. - (parameterize ([current-insert-text inserted-text]) - (tellv self interpretKeyEvents: (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event - count: #:type _NSUInteger 1))) - + (unless wheel? + ;; Calling `interpretKeyEvents:' allows key combinations to be + ;; handled, such as option-e followed by e to produce é. The + ;; call to `interpretKeyEvents:' typically calls `insertText:', + ;; so we set `current-insert-text' to tell `insertText:' to just + ;; give us back the text in the parameter. For now, we ignore the + ;; text and handle the event as usual, though probably we should + ;; be doing something with it. + (parameterize ([current-insert-text inserted-text]) + (tellv self interpretKeyEvents: (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)))) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)] + [str (if wheel? + #f + (tell #:type _NSString event characters))] [control? (bit? modifiers NSControlKeyMask)] - [option? (bit? modifiers NSAlternateKeyMask)]) + [option? (bit? modifiers NSAlternateKeyMask)] + [delta-y (and wheel? + (tell #:type _CGFloat event deltaY))]) (let-values ([(x y) (send wx window-point-to-view pos)]) (let ([k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1a) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c))))] + [key-code (if wheel? + (if (positive? delta-y) + 'wheel-up + 'wheel-down) + (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1a) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0)))) + c)))))] [shift-down (bit? modifiers NSShiftKeyMask)] [control-down control?] [meta-down (bit? modifiers NSCommandKeyMask)] @@ -222,23 +235,24 @@ [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (when (and option? - special-option-key? - (send k get-other-altgr-key-code)) - ;; swap altenate with main - (let ([other (send k get-other-altgr-key-code)]) - (send k set-other-altgr-key-code (send k get-key-code)) - (send k set-key-code other))) - (unless down? - ;; swap altenate with main - (send k set-key-release-code (send k get-key-code)) - (send k set-key-code 'release)) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and option? + special-option-key? + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) + (unless 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 definitely-wants-event? k) (begin (queue-window-event wx (lambda () diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 71ad4fdd..44d17d46 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -156,9 +156,10 @@ (when (or (not (equal? #\u0000 key-code)) (let-values ([(s ag sag cl) (get-alts event)] [(keyval->code*) (lambda (v) - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 key-code)) - c)))]) + (and v + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 key-code)) + c))))]) (let ([s (keyval->code* s)] [ag (keyval->code* ag)] [sag (keyval->code* sag)] diff --git a/collects/scribblings/gui/key-event-class.scrbl b/collects/scribblings/gui/key-event-class.scrbl index 9e0ddf41..6a9957a4 100644 --- a/collects/scribblings/gui/key-event-class.scrbl +++ b/collects/scribblings/gui/key-event-class.scrbl @@ -164,9 +164,10 @@ The special key symbols attempt to capture useful keys that have no If a suitable special key symbol or ASCII representation is not available, @scheme[#\nul] (the NUL character) is reported. -Under X, a @scheme['wheel-up] or @scheme['wheel-down] event may be sent - to a window other than the one with the keyboard focus, because X - generates wheel events based on the location of the mouse pointer. +A @scheme['wheel-up] or @scheme['wheel-down] event may be sent to a + window other than the one with the keyboard focus, because some + platforms generate wheel events based on the location of the mouse + pointer instead of the keyboard focus. Under Windows, when the Control key is pressed without Alt, the key code for ASCII characters is downcased, roughly cancelling the effect From 31db06a387b401cc2efc2aebe715bf8841da696c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 11:16:15 -0600 Subject: [PATCH 201/462] wheel events for gtk original commit: f41bd0ffc130e72267216a45466f2393ce92b1d7 --- collects/mred/private/wx/gtk/const.rkt | 6 +++ collects/mred/private/wx/gtk/types.rkt | 14 ++++++ collects/mred/private/wx/gtk/window.rkt | 65 ++++++++++++++++--------- 3 files changed, 62 insertions(+), 23 deletions(-) diff --git a/collects/mred/private/wx/gtk/const.rkt b/collects/mred/private/wx/gtk/const.rkt index 5a3edc96..54b8cb0e 100644 --- a/collects/mred/private/wx/gtk/const.rkt +++ b/collects/mred/private/wx/gtk/const.rkt @@ -130,3 +130,9 @@ (define GDK_HINT_WIN_GRAVITY (1 . << . 6)) (define GDK_HINT_USER_POS (1 . << . 7)) (define GDK_HINT_USER_SIZE (1 . << . 8)) + +(define GDK_SCROLL_UP 0) +(define GDK_SCROLL_DOWN 1) +(define GDK_SCROLL_LEFT 2) +(define GDK_SCROLL_RIGHT 3) + diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 95103c5b..3e5b1afe 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -15,6 +15,8 @@ (struct-out GdkEventButton) _GdkEventKey _GdkEventKey-pointer (struct-out GdkEventKey) + _GdkEventScroll _GdkEventScroll-pointer + (struct-out GdkEventScroll) _GdkEventMotion _GdkEventMotion-pointer (struct-out GdkEventMotion) _GdkEventCrossing _GdkEventCrossing-pointer @@ -67,6 +69,18 @@ [group _ubyte] [is_modifier _byte])) ; just 1 bit +(define-cstruct _GdkEventScroll ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [state _uint] + [direction _uint] + [device _GdkDevice] + [x_root _double] + [y_root _double])) + (define-cstruct _GdkEventMotion ([type _GdkEventType] [window _GdkWindow] [send_event _byte] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 44d17d46..e4414c6b 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -125,24 +125,39 @@ (define-signal-handler connect-key-press "key-press-event" (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) - (do-key-event gtk event #t))) + (do-key-event gtk event #t #f))) (define-signal-handler connect-key-release "key-release-event" (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) - (do-key-event gtk event #f))) + (do-key-event gtk event #f #f))) -(define (do-key-event gtk event down?) +(define-signal-handler connect-scroll "scroll-event" + (_fun _GtkWidget _GdkEventScroll-pointer -> _gboolean) + (lambda (gtk event) + (and (member (GdkEventScroll-direction event) + (list GDK_SCROLL_UP + GDK_SCROLL_DOWN)) + (do-key-event gtk event #f #t)))) + +(define (do-key-event gtk event down? scroll?) (let ([wx (gtk->wx gtk)]) (and wx - (let* ([modifiers (GdkEventKey-state 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 (keyval->code (GdkEventKey-keyval event))] + [key-code (if scroll? + (if (= (GdkEventScroll-direction event) + GDK_SCROLL_UP) + 'wheel-up + 'wheel-down) + (keyval->code (GdkEventKey-keyval event)))] [k (new key-event% [key-code key-code] [shift-down (bit? modifiers GDK_SHIFT_MASK)] @@ -151,25 +166,28 @@ [alt-down (bit? modifiers GDK_MOD1_MASK)] [x 0] [y 0] - [time-stamp (GdkEventKey-time event)] + [time-stamp (if scroll? + (GdkEventScroll-time event) + (GdkEventKey-time event))] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (when (or (not (equal? #\u0000 key-code)) - (let-values ([(s ag sag cl) (get-alts event)] - [(keyval->code*) (lambda (v) - (and v - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 key-code)) - 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 (keyval->code s))) - (when ag (send k set-other-altgr-key-code (keyval->code ag))) - (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) - (when cl (send k set-other-caps-key-code (keyval->code cl))) - (or s ag sag cl)))) - (unless down? + (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)) @@ -216,6 +234,7 @@ (define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) (connect-key-release gtk) + (connect-scroll gtk) (connect-button-press gtk) (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) From 921d351bf6c05618b8c0577246c7a32b1cd1a3db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 15:39:06 -0600 Subject: [PATCH 202/462] toward better refresh for gtk & other bug fixes original commit: e72cf8517584c9904a5279c2cd7d587d372f67f6 --- collects/mred/private/wx/cocoa/canvas.rkt | 3 ++ collects/mred/private/wx/cocoa/dc.rkt | 26 ++--------- collects/mred/private/wx/cocoa/window.rkt | 28 +++++------ .../mred/private/wx/common/backing-dc.rkt | 26 +++++++++-- collects/mred/private/wx/common/delay.rkt | 27 +++++++++++ collects/mred/private/wx/common/queue.rkt | 37 +++++++++++---- collects/mred/private/wx/gtk/canvas.rkt | 3 ++ collects/mred/private/wx/gtk/cursor.rkt | 1 - collects/mred/private/wx/gtk/dc.rkt | 40 +++++++++------- collects/mred/private/wx/gtk/message.rkt | 3 +- collects/mred/private/wx/gtk/procs.rkt | 6 +-- collects/mred/private/wx/gtk/queue.rkt | 16 ++++++- collects/mred/private/wx/gtk/types.rkt | 3 ++ collects/mred/private/wx/gtk/utils.rkt | 4 +- collects/mred/private/wx/gtk/window.rkt | 46 ++++++++++++++++++- collects/mred/private/wxme/text.rkt | 4 +- 16 files changed, 194 insertions(+), 79 deletions(-) create mode 100644 collects/mred/private/wx/common/delay.rkt diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 3be04ed7..6a000998 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -263,6 +263,9 @@ (define/public (end-refresh-sequence) (send dc resume-flush)) + (define/public (get-flush-window) + (get-cocoa-window)) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread (queue-paint)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index c8986fc4..00aa41d2 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -39,8 +39,6 @@ (cairo_surface_destroy s) (set! s #f))))) -(define-local-member-name end-delay) - (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -65,26 +63,10 @@ ;; called atomically (not expecting exceptions) (send canvas queue-backing-flush)) - (define suspend-count 0) - (define req #f) - - (define/override (suspend-flush) - (atomically - (when (zero? suspend-count) - (when req (cancel-flush-delay req)) - (set! req (request-flush-delay (send canvas get-cocoa-window)))) - (set! suspend-count (add1 suspend-count)) - (super suspend-flush))) - - (define/override (resume-flush) - (atomically - (set! suspend-count (sub1 suspend-count)) - (super resume-flush))) - - (define/public (end-delay) - (when (and (zero? suspend-count) req) - (cancel-flush-delay req) - (set! req #f))))) + (define/override (request-delay) + (request-flush-delay (send canvas get-flush-window))) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 28deb6d7..269c6545 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -13,6 +13,7 @@ "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" + "../common/delay.rkt" "../../syntax.rkt" "../common/freeze.rkt") (unsafe!) @@ -651,25 +652,18 @@ (queue-event (send wx get-eventspace) (lambda () (proc wx)))))) (define (request-flush-delay cocoa-win) - (atomically - (let ([req (box cocoa-win)]) - (tellv cocoa-win disableFlushWindow) - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (tellv cocoa-win enableFlushWindow)))) - req))) + (do-request-flush-delay + cocoa-win + (lambda (cocoa-win) + (tellv cocoa-win disableFlushWindow)) + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) (define (cancel-flush-delay req) - (atomically - (let ([cocoa-win (unbox req)]) - (when cocoa-win - (set-box! req #f) - (tellv cocoa-win enableFlushWindow) - (remove-event-boundary-callback! req))))) + (do-cancel-flush-delay + req + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) (define (make-init-point x y) (make-NSPoint (if (= x -11111) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 4c640897..4d5e71b2 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -16,7 +16,10 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap%) + get-bitmap% + request-delay + cancel-delay + end-delay) (define-local-member-name get-backing-size @@ -25,7 +28,10 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap%) + get-bitmap% + request-delay + cancel-delay + end-delay) (define backing-dc% (class (dc-mixin bitmap-dc-backend%) @@ -110,15 +116,29 @@ (queue-backing-flush))) (define flush-suspends 0) + (define req #f) + + (define/public (request-delay) (void)) + (define/public (cancel-delay req) (void)) (define/override (suspend-flush) (atomically + (when (zero? flush-suspends) + (when req (cancel-delay req)) + (set! req (request-delay))) (set! flush-suspends (add1 flush-suspends)))) + (define/override (resume-flush) (atomically (set! flush-suspends (sub1 flush-suspends)) (when (zero? flush-suspends) - (queue-backing-flush)))))) + (queue-backing-flush)))) + + (define/public (end-delay) + ;; call in atomic mode + (when (and (zero? flush-suspends) req) + (cancel-delay req) + (set! req #f))))) (define (get-backing-bitmap bitmap% w h) (make-object bitmap% w h #f #t)) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt new file mode 100644 index 00000000..ef2aba0a --- /dev/null +++ b/collects/mred/private/wx/common/delay.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require "../../lock.rkt" + "queue.rkt") + +(provide do-request-flush-delay + do-cancel-flush-delay) + +(define (do-request-flush-delay win disable enable) + (atomically + (let ([req (box win)]) + (disable win) + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win)))) + req))) + +(define (do-cancel-flush-delay req enable) + (atomically + (let ([win (unbox req)]) + (when win + (set-box! req #f) + (enable win) + (remove-event-boundary-callback! req))))) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 0f0672e6..700b1c83 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -15,6 +15,7 @@ add-event-boundary-sometimes-callback! remove-event-boundary-callback! pre-event-sync + boundary-tasks-ready-evt eventspace? current-eventspace @@ -97,16 +98,35 @@ (define boundary-ht (make-hasheq)) (define sometimes-boundary-ht (make-hasheq)) -(define (add-event-boundary-callback! v proc) - (hash-set! boundary-ht v proc)) +(define tasks-ready? #f) +(define task-ready-sema (make-semaphore)) +(define boundary-tasks-ready-evt (semaphore-peek-evt task-ready-sema)) + +(define (alert-tasks-ready) + (let ([ready? (or (positive? (hash-count boundary-ht)) + (positive? (hash-count sometimes-boundary-ht)))]) + (unless (eq? ready? tasks-ready?) + (set! tasks-ready? ready?) + (if ready? + (semaphore-post task-ready-sema) + (semaphore-wait task-ready-sema))))) + +(define (add-event-boundary-callback! v proc) + (atomically + (alert-tasks-ready) + (hash-set! boundary-ht v proc))) (define (add-event-boundary-sometimes-callback! v proc) - (when (zero? (hash-count sometimes-boundary-ht)) - (set! last-time (current-inexact-milliseconds))) - (hash-set! sometimes-boundary-ht v proc)) + (atomically + (alert-tasks-ready) + (when (zero? (hash-count sometimes-boundary-ht)) + (set! last-time (current-inexact-milliseconds))) + (hash-set! sometimes-boundary-ht v proc))) (define (remove-event-boundary-callback! v) - (hash-remove! boundary-ht v) - (hash-remove! sometimes-boundary-ht v)) + (atomically + (hash-remove! boundary-ht v) + (hash-remove! sometimes-boundary-ht v) + (alert-tasks-ready))) (define last-time -inf.0) @@ -118,7 +138,8 @@ (set! last-time now) (hash-for-each sometimes-boundary-ht (lambda (v p) (hash-remove! sometimes-boundary-ht v) (p v))))) - (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v)))) + (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v))) + (alert-tasks-ready)) ;; ------------------------------------------------------------ ;; Eventspaces diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 748bd5e7..f0d39bb0 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -375,6 +375,8 @@ (define/public (on-paint) (void)) + (define/public (get-flush-window) client-gtk) + (define/public (begin-refresh-sequence) (void)) (define/public (end-refresh-sequence) (void)) @@ -393,6 +395,7 @@ (define/private (reset-dc) (send dc reset-backing-retained) + (refresh) (send dc set-auto-scroll (if virtual-width (gtk_adjustment_get_value hscroll-adj) diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index fb6d7420..564e6536 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -37,7 +37,6 @@ (define _GdkCursor (_cpointer 'GdkCursor)) (define-gdk gdk_cursor_new (_fun _int -> _GdkCursor)) -(define _GdkDisplay (_cpointer 'GdkDisplay)) (define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) (define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a4a812dc..6907353d 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -3,6 +3,7 @@ racket/class "utils.rkt" "types.rkt" + "window.rkt" "../../lock.rkt" "../common/backing-dc.rkt" racket/draw/cairo @@ -34,21 +35,28 @@ (define/override (queue-backing-flush) ;; called atomically (not expecting exceptions) - (send canvas queue-backing-flush)))) + (send canvas queue-backing-flush)) + + (define/override (request-delay) + (request-flush-delay (send canvas get-flush-window))) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) (define (do-backing-flush canvas dc win) - (send dc on-backing-flush - (lambda (bm) - (let ([w (box 0)] - [h (box 0)]) - (send canvas get-client-size w h) - (let ([cr (gdk_cairo_create win)]) - (let ([s (cairo_get_source cr)]) - (cairo_pattern_reference s) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 (unbox w) (unbox h)) - (cairo_fill cr) - (cairo_set_source cr s) - (cairo_pattern_destroy s)) - (cairo_destroy cr)))))) + (begin0 + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cr (gdk_cairo_create win)]) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr))))) + (send dc end-delay))) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 5f2552a5..aa3c26b9 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -64,7 +64,8 @@ (as-gtk-allocation (gtk_image_new_from_pixbuf pixbuf)) (release-pixbuf pixbuf))) - (gtk_label_new_with_mnemonic ""))))] + (as-gtk-allocation + (gtk_label_new_with_mnemonic "")))))] [no-show? (memq 'deleted style)]) (when (string? label) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index c7e91cbd..67e44296 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -9,6 +9,7 @@ "utils.rkt" "style.rkt" "widget.rkt" + "window.rkt" "../common/handlers.rkt") (provide @@ -92,11 +93,6 @@ (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) -(define _GdkDisplay (_cpointer 'GdkDisplay)) -(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) -(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) -(define (flush-display) (gdk_display_flush (gdk_display_get_default))) - (define-unimplemented write-resource) (define-unimplemented get-resource) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 8abda62e..332c7c3d 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -11,6 +11,8 @@ (provide gtk-start-event-pump + try-to-sync-refresh + set-widget-hook! ;; from common/queue: @@ -68,7 +70,6 @@ #:fail #f) (define (install-wakeup fds) - (pre-event-sync #t) (let ([n (g_main_context_query (g_main_context_default) #x7FFFFFFF ; max-int, hopefully timeout @@ -135,9 +136,20 @@ (gtk_main_iteration_do #f) (dispatch-all-ready))) +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + (define (gtk-start-event-pump) (thread (lambda () (let loop () - (sync queue-evt) + (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) + (sync queue-evt (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) + (pre-event-sync #t)) (atomically (dispatch-all-ready)) (loop))))) + +(define (try-to-sync-refresh) + (atomically + (pre-event-sync #t))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 3e5b1afe..2f51e5e2 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -4,6 +4,7 @@ (provide _GdkWindow _GtkWidget _GtkWindow + _GdkDisplay _gpointer _GType @@ -34,6 +35,8 @@ (define _GtkWidget (_cpointer 'GtkWidget)) (define _GtkWindow _GtkWidget) +(define _GdkDisplay (_cpointer 'GdkDisplay)) + (define _gpointer _GtkWidget) (define _GdkDevice (_cpointer 'GdkDevice)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index f91f6a96..6a1007c8 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -125,7 +125,9 @@ (g_object_ref_sink v) v))))) (define-syntax-rule (as-gtk-window-allocation expr) - ((gtk-allocator (lambda () expr)))) + ((gtk-allocator (lambda () (let ([v expr]) + (g_object_ref v) + v))))) (define-glib g_free (_fun _pointer -> _void)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e4414c6b..b6a00d61 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -8,6 +8,7 @@ "../common/freeze.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/delay.rkt" "keycode.rkt" "keymap.rkt" "queue.rkt" @@ -42,7 +43,13 @@ the-accelerator-group gtk_window_add_accel_group - gtk_menu_set_accel_group) + gtk_menu_set_accel_group + + flush-display + gdk_display_get_default + + request-flush-delay + cancel-flush-delay) ;; ---------------------------------------- @@ -517,14 +524,26 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) + (define/private (pre-event-refresh) + ;; Since we break the connection between the + ;; Gtk queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (try-to-sync-refresh) + (gdk_window_process_all_updates) + (flush-display)) + (define/public (handles-events? gtk) #f) (define/public (dispatch-on-char e just-pre?) + (pre-event-refresh) (cond [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) + (pre-event-refresh) (cond [(other-modal? this) #t] [(call-pre-on-event this e) #t] @@ -591,3 +610,28 @@ (queue-event (send win get-eventspace) thunk)) (define (queue-window-refresh-event win thunk) (queue-refresh-event (send win get-eventspace) thunk)) + +(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_sync (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define (flush-display) (gdk_display_flush (gdk_display_get_default))) +(define (sync-display) (gdk_display_sync (gdk_display_get_default))) + +(define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void)) +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + +(define (request-flush-delay gtk) + (do-request-flush-delay + gtk + (lambda (gtk) + (gdk_window_freeze_updates (widget-window gtk))) + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))) + +(define (cancel-flush-delay req) + (do-cancel-flush-delay + req + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 3736bda0..86458dee 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -4980,8 +4980,8 @@ (dc . is-a? . printer-dc%))] [show-xsel? (and ALLOW-X-STYLE-SELECTION? - (or (not (eq? 'show-caret show-caret)) - (not (pair? show-caret)) + (or (and (not (eq? 'show-caret show-caret)) + (not (pair? show-caret))) s-caret-snip) (eq? this editor-x-selection-owner) (not flash?) From 7bb2848333791d0f64e35d7b34325a80cb3c7a1b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 18:10:01 -0600 Subject: [PATCH 203/462] fix clipboard eventspace problem original commit: 85ce22d4f7ed1d78c1cea6932b3ea44654efd7dd --- collects/mred/private/wx/common/clipboard.rkt | 2 ++ collects/mred/private/wx/common/local.rkt | 1 + 2 files changed, 3 insertions(+) diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt index 09d81c8a..7d96c062 100644 --- a/collects/mred/private/wx/common/clipboard.rkt +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -14,6 +14,7 @@ (define types null) (define es (current-eventspace)) (define/public (get-client-eventspace) es) + (define/public (set-client-eventspace e) (set! es e)) (def/public (same-eventspace? [eventspace? e]) (eq? e es)) (def/public (get-types) @@ -47,6 +48,7 @@ (def/public (set-clipboard-client [clipboard-client% c] [exact-integer? timestamp]) + (send c set-client-eventspace (current-eventspace)) (send driver set-client c (send c get-types))) (super-new)) diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt index 6ffb76cb..0f1d6a08 100644 --- a/collects/mred/private/wx/common/local.rkt +++ b/collects/mred/private/wx/common/local.rkt @@ -6,6 +6,7 @@ (define-local-member-name ;; clipboard-client%: get-client-eventspace + set-client-eventspace ;; cursor% get-driver) From 10762db8c3a892f054dfb54a636afbcb6c569a15 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 19:57:42 -0600 Subject: [PATCH 204/462] collecting blit for gtk original commit: a2f02f6f39ae7cb5158d8e6ba88083dc23225665 --- collects/mred/private/wx/gtk/canvas.rkt | 38 ++++++++++- collects/mred/private/wx/gtk/gcwin.rkt | 83 +++++++++++++++++++++++++ collects/mred/private/wx/gtk/procs.rkt | 6 +- 3 files changed, 123 insertions(+), 4 deletions(-) create mode 100644 collects/mred/private/wx/gtk/gcwin.rkt diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index f0d39bb0..52af2441 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -16,7 +16,9 @@ "client-window.rkt" "widget.rkt" "dc.rkt" - "combo.rkt") + "combo.rkt" + "pixbuf.rkt" + "gcwin.rkt") (provide canvas%) @@ -588,5 +590,37 @@ (define/public (get-virtual-size xb yb) (get-client-size xb yb) (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))))) + (when virtual-height (set-box! yb virtual-height))) + (define reg-blits null) + + (define/private (register-one-blit x y w h pixbuf) + (let* ([cwin (widget-window client-gtk)]) + (atomically + (let ([win (create-gc-window cwin x y w h pixbuf)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc win pixbuf w h) + (make-gc-hide-desc win))]) + (cons win r)))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))]) + (let ([pixbuf (bitmap->pixbuf on)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h pixbuf) reg-blits)))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (g_object_unref (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null))))) diff --git a/collects/mred/private/wx/gtk/gcwin.rkt b/collects/mred/private/wx/gtk/gcwin.rkt new file mode 100644 index 00000000..94ee1b26 --- /dev/null +++ b/collects/mred/private/wx/gtk/gcwin.rkt @@ -0,0 +1,83 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "window.rkt") + +(provide scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-window + make-gc-show-desc + make-gc-hide-desc) + +(define-cstruct _GdkWindowAttr + ([title _string] + [event_mask _int] + [x _int] + [y _int] + [width _int] + [height _int] + [wclass _int] ; GDK_INPUT_OUTPUT + [visual _pointer] + [colormap _pointer] + [window_type _int] ; GDK_WINDOW_CHILD + [cursor _pointer] + [wmclass_name _string] + [wmclass_class _string] + [override_redirect _gboolean] + [type_hint _int])) + +(define << arithmetic-shift) + +(define GDK_WA_TITLE (1 . << . 1)) +(define GDK_WA_X (1 . << . 2)) +(define GDK_WA_Y (1 . << . 3)) +(define GDK_WA_CURSOR (1 . << . 4)) +(define GDK_WA_COLORMAP (1 . << . 5)) +(define GDK_WA_VISUAL (1 . << . 6)) +(define GDK_WA_WMCLASS (1 . << . 7)) +(define GDK_WA_NOREDIR (1 . << . 8)) +(define GDK_WA_TYPE_HINT (1 . << . 9)) + +(define GDK_INPUT_OUTPUT 0) + +(define GDK_WINDOW_CHILD 2) + +(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint + -> _GdkWindow)) + +(define-gdk gdk_window_show _fpointer) +(define-gdk gdk_window_hide _fpointer) +(define-gdk gdk_display_flush _fpointer) +(define-gdk gdk_draw_pixbuf _fpointer) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define (create-gc-window cwin x y w h pixbuf) + (let ([win (gdk_window_new cwin (make-GdkWindowAttr + "" + 0 + x y w h + GDK_INPUT_OUTPUT + #f #f + GDK_WINDOW_CHILD + #f + "" "" #f 0) + (bitwise-ior GDK_WA_X + GDK_WA_Y))]) + win)) + +(define (make-gc-show-desc win pixbuf w h) + (vector + (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f) + (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void + gdk_draw_pixbuf + win #f pixbuf + 0 0 0 0 w h + 0 0 0) + (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))) + +(define (make-gc-hide-desc win) + (vector + (vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 67e44296..96162e9d 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -70,8 +70,10 @@ (define-unimplemented play-sound) (define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) -(define (register-collecting-blit . args) (void)) -(define (unregister-collecting-blit . args) (void)) +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [mbar? #f]) #t) (define-unimplemented in-atomic-region) (define (set-menu-tester proc) (void)) From e1baebd20e3b3a0d076ffa0f08dda89a2c6e7773 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 20:09:53 -0600 Subject: [PATCH 205/462] update docs for `register-collecting-blit' original commit: 79728fad59fbc3cb1d40e4875d703e92a4da2991 --- .../scribblings/gui/global-draw-funcs.scrbl | 41 ------------------ collects/scribblings/gui/miscwin-funcs.scrbl | 42 ++++++++++++++++++- 2 files changed, 40 insertions(+), 43 deletions(-) diff --git a/collects/scribblings/gui/global-draw-funcs.scrbl b/collects/scribblings/gui/global-draw-funcs.scrbl index 0ff0932f..2790d63d 100644 --- a/collects/scribblings/gui/global-draw-funcs.scrbl +++ b/collects/scribblings/gui/global-draw-funcs.scrbl @@ -57,44 +57,3 @@ Returns @scheme[#t] if the main display has color, @scheme[#f] otherwise. } - -@defproc[(register-collecting-blit [canvas (is-a?/c canvas%)] - [x real?] - [y real?] - [w (and/c real? (not/c negative?))] - [h (and/c real? (not/c negative?))] - [on (is-a?/c bitmap%)] - [off (is-a?/c bitmap%)] - [on-x real? 0] - [on-y real? 0] - [off-x real? 0] - [off-y real? 0]) - void?]{ - -Registers a blit to occur when garbage collection starts or ends. - -When garbage collection starts, @scheme[(send (send canvas #,(:: - canvas<%> get-dc)) #,(:: dc<%> draw-bitmap-section) on on-x on-y x y w - h)] is called. When garbage collection ends, @scheme[(send (send - canvas #,(:: canvas<%> get-dc)) #,(:: dc<%> draw-bitmap-section) off - off-x off-y x y w h)] is called. If @scheme[canvas]'s device context - has a scale, the scale may or may not be temporarily disabled during - the bitmap drawing. - -The @scheme[canvas] is registered weakly, so it will be automatically - unregistered if the canvas becomes invisible and inaccessible. - Multiple registrations can be installed for the same canvas. - -See also @scheme[unregister-collecting-blit]. - -} - -@defproc[(unregister-collecting-blit [canvas (is-a?/c canvas%)]) - void?]{ - -Unregisters a blit request installed with See also - @scheme[register-collecting-blit]. - -Unregisters all blits for @scheme[canvas]. - -} diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index a0291113..5938b1cc 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -317,11 +317,49 @@ Under X, the function invokes an external sound-playing program; Under Mac OS X, Quicktime is used to play sounds; most sound formats (.wav, .aiff, .mp3) are supported in recent versions of Quicktime. In order to play .wav files, Quicktime 3.0 (compatible - with OS 7.5 and up) is required. + with OS 7.5 and up) is required.} +@defproc[(register-collecting-blit [canvas (is-a?/c canvas%)] + [x real?] + [y real?] + [w (and/c real? (not/c negative?))] + [h (and/c real? (not/c negative?))] + [on (is-a?/c bitmap%)] + [off (is-a?/c bitmap%)] + [on-x real? 0] + [on-y real? 0] + [off-x real? 0] + [off-y real? 0]) + void?]{ -} +Registers a ``blit'' to occur when garbage collection starts and + ends. When garbage collection starts, @racket[on] is drawn at + location @racket[x] and @racket[y] within @racket[canvas], if + @racket[canvas] is shown. When garbage collection ends, the drawing + is reverted. The @racket[off], @racket[off-x], and @racket[off-y] + arguments are currently unused, though they were formerly used to + revert the drawing of @racket[on]. + +The background behind @racket[on] is unspecified, so @racket[on] + should be a solid image, and the canvas's scale or scrolling is not + applied to the drawing. Only the portion of @racket[on] within + @racket[w] and @racket[h] pixels is used; if @racket[on-x] and + @racket[on-y] are specified, they specify an offset within the bitmap + that is used for drawing. + +The blit is automatically unregistered if @scheme[canvas] becomes + invisible and inaccessible. Multiple registrations can be installed + for the same @scheme[canvas]. + +See also @scheme[unregister-collecting-blit].} + + +@defproc[(unregister-collecting-blit [canvas (is-a?/c canvas%)]) + void?]{ + +Unregisters all blit requests installed for @racket[canvas] with + @scheme[register-collecting-blit].} @defproc[(send-event [receiver-bytes (lambda (s) (and (bytes? s) From 3b7c5a78ea97961e371af5053f3e4e20be5d9c89 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 08:55:16 -0600 Subject: [PATCH 206/462] selection and cocoa clipboard fixes original commit: f51345b512d5cd744e9bb03ad6ee15ff53881753 --- collects/mred/private/wx/cocoa/clipboard.rkt | 47 +++++++++++--------- collects/mred/private/wxme/text.rkt | 8 ++-- 2 files changed, 30 insertions(+), 25 deletions(-) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index c77307b2..c1c2dd73 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -5,7 +5,8 @@ "utils.rkt" "types.rkt" "../common/bstr.rkt" - "../../syntax.rkt") + "../../syntax.rkt" + "../../lock.rkt") (provide clipboard-driver% has-x-selection?) @@ -49,20 +50,22 @@ #f))))) (define/public (set-client c types) - (let ([pb (tell NSPasteboard generalPasteboard)] - [a (tell NSArray arrayWithObjects: - #:type (_list i _NSString) (map map-type types) - count: #:type _NSUInteger (length types))]) - (set! counter (tell #:type _NSInteger pb clearContents)) - (set! client c) - (for ([type (in-list types)]) - (let* ([bstr (send c get-data type)] - [data (tell NSData - dataWithBytes: #:type _bytes bstr - length: #:type _NSUInteger (bytes-length bstr))]) - (tellv (tell NSPasteboard generalPasteboard) - setData: data - forType: #:type _NSString (map-type type)))))) + (atomically + (with-autorelease + (let ([pb (tell NSPasteboard generalPasteboard)] + [a (tell NSArray arrayWithObjects: + #:type (_list i _NSString) (map map-type types) + count: #:type _NSUInteger (length types))]) + (set! counter (tell #:type _NSInteger pb clearContents)) + (set! client c) + (for ([type (in-list types)]) + (let* ([bstr (send c get-data type)] + [data (tell NSData + dataWithBytes: #:type _bytes bstr + length: #:type _NSUInteger (bytes-length bstr))]) + (tellv (tell NSPasteboard generalPasteboard) + setData: data + forType: #:type _NSString (map-type type)))))))) (define/public (get-data-for-type type) (log-error "didn't expect clipboard data request")) @@ -73,9 +76,11 @@ (bytes->string/utf-8 bstr #\?)))) (define/public (get-data type) - (let* ([pb (tell NSPasteboard generalPasteboard)] - [data (tell pb dataForType: #:type _NSString (map-type type))]) - (and data - (let ([len (tell #:type _NSUInteger data length)] - [bstr (tell #:type _pointer data bytes)]) - (scheme_make_sized_byte_string bstr len 1)))))) + (atomically + (with-autorelease + (let* ([pb (tell NSPasteboard generalPasteboard)] + [data (tell pb dataForType: #:type _NSString (map-type type))]) + (and data + (let ([len (tell #:type _NSUInteger data length)] + [bstr (tell #:type _pointer data bytes)]) + (scheme_make_sized_byte_string bstr len 1)))))))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 86458dee..336bc375 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5188,10 +5188,10 @@ (if (eq? snip s-caret-snip) show-caret (if (and maybe-hilite? - (endpos . > . p) - (startpos . < . (+ p (snip->count snip)))) - (cons (max 0 (- startpos p)) - (min (snip->count snip) (- endpos p))) + (-endpos . > . p) + (-startpos . < . (+ p (snip->count snip)))) + (cons (max 0 (- -startpos p)) + (min (snip->count snip) (- -endpos p))) 'no-caret)))))) ;; the rules for hiliting are surprisingly complicated: From 883b6c972be0e7db8e810deb161ed42dfd1ec00f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 12:56:21 -0600 Subject: [PATCH 207/462] fix flash highlight original commit: 3a17b284a7f454567340e97bf59a9806bedce3ed --- collects/mred/private/wxme/text.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 336bc375..b8a4982e 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5261,8 +5261,8 @@ (and s-caret-snip (not (pair? show-caret))) (not hilite-on?) (= -startpos -endpos) - (endpos . < . pcounter) - (startpos . > . (+ pcounter (mline-len line))))] + (-endpos . < . pcounter) + (-startpos . > . (+ pcounter (mline-len line))))] [(hilite-some? hsxs hsxe hsys hsye old-style) (process-snips draw-first? #f old-style)]) (when (and (positive? wrap-bitmap-width) From 775be3b3172d85baa0d8ea99dba6dacbc3a40765 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 13:49:00 -0600 Subject: [PATCH 208/462] cocoa button fixes original commit: 221c423402faa0fc65f16785875d99a755efea8c --- collects/mred/private/wx/cocoa/button.rkt | 12 +++++++----- collects/mred/private/wx/cocoa/window.rkt | 7 ++++--- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 936af610..97574919 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -22,6 +22,7 @@ (import-class NSButton NSView NSImageView) (define MIN-BUTTON-WIDTH 72) +(define BUTTON-EXTRA-WIDTH 12) (define-objc-class MyButton NSButton #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) @@ -62,11 +63,12 @@ (when (and (eq? event-type 'button) (string? label)) (let ([frame (tell #:type _NSRect cocoa frame)]) - (when ((NSSize-width (NSRect-size frame)) . < . MIN-BUTTON-WIDTH) - (tellv cocoa setFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize MIN-BUTTON-WIDTH - (NSSize-height (NSRect-size frame)))))))) + (tellv cocoa setFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize (+ BUTTON-EXTRA-WIDTH + (max MIN-BUTTON-WIDTH + (NSSize-width (NSRect-size frame)))) + (NSSize-height (NSRect-size frame))))))) cocoa)) (define cocoa (if (and button-type diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 269c6545..00debc66 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -484,9 +484,10 @@ (void)) (define/public (set-focus) - (let ([w (tell cocoa window)]) - (when w - (tellv w makeFirstResponder: (get-cocoa-content))))) + (when (gets-focus?) + (let ([w (tell cocoa window)]) + (when w + (tellv w makeFirstResponder: (get-cocoa-content)))))) (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) From 4ab3da47a98309e4f91ca9e46443ab26423ff6a7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 14:20:51 -0600 Subject: [PATCH 209/462] fix focus and frame-modified problems original commit: af499e303930f8ba117f979bb1fa260416c55152 --- collects/mred/private/wx/cocoa/canvas.rkt | 9 ++++++++- collects/mred/private/wx/cocoa/frame.rkt | 6 ++++-- collects/mred/private/wx/cocoa/window.rkt | 5 ++++- collects/mred/private/wx/gtk/canvas.rkt | 5 +++-- collects/mred/private/wx/gtk/frame.rkt | 16 +++++++++++++--- 5 files changed, 32 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 6a000998..a29c47d6 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -192,6 +192,7 @@ (define virtual-height #f) (define virtual-width #f) + (define wants-focus? (not (memq 'no-focus style))) (define is-combo? (memq 'combo style)) (define has-control-border? (and (not is-combo?) (memq 'control-border style))) @@ -656,7 +657,8 @@ (define/override (definitely-wants-event? e) ;; Called in Cocoa event-handling mode - (when (and (e . is-a? . mouse-event%) + (when (and wants-focus? + (e . is-a? . mouse-event%) (send e button-down? 'left)) (set-focus)) (or (not is-combo?) @@ -664,6 +666,11 @@ (not (send e button-down? 'left)) (not (on-menu-click? e)))) + (define/override (gets-focus?) + wants-focus?) + (define/override (can-be-responder?) + wants-focus?) + (define/private (on-menu-click? e) ;; Called in Cocoa event-handling mode (let ([xb (box 0)] diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 457035ff..460251d9 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -23,6 +23,8 @@ (import-class NSWindow NSGraphicsContext NSMenu NSPanel NSApplication NSAutoreleasePool NSScreen) +(define NSWindowCloseButton 0) + (define front #f) (define (get-front) front) @@ -459,8 +461,8 @@ (def/public-unimplemented system-menu) (define/public (set-modified on?) - ;; Use standardWindowButton: ... - (void)) + (let ([b (tell cocoa standardWindowButton: #:type _NSInteger NSWindowCloseButton)]) + (tellv b setDocumentEdited: #:type _BOOL on?))) (define/public (create-status-line) (void)) (define/public (set-status-text s) (void)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 00debc66..033f8da7 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -57,7 +57,9 @@ (define-objc-mixin (FocusResponder Superclass) [wxb] [-a _BOOL (acceptsFirstResponder) - #t] + (let ([wx (->wx wxb)]) + (or (not wx) + (send wx can-be-responder?)))] [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) (let ([wx (->wx wxb)]) @@ -635,6 +637,7 @@ (define/public (get-cursor-width-delta) 0) (define/public (gets-focus?) #f) + (define/public (can-be-responder?) #t) (def/public-unimplemented centre))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 52af2441..26200fcd 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -305,8 +305,9 @@ GDK_FOCUS_CHANGE_MASK GDK_ENTER_NOTIFY_MASK GDK_LEAVE_NOTIFY_MASK)) - (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) - GTK_CAN_FOCUS)) + (unless (memq 'no-focus style) + (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) + GTK_CAN_FOCUS))) (when combo-button-gtk (connect-combo-key-and-mouse combo-button-gtk)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index a1054c74..c872fcb9 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -136,6 +136,9 @@ (connect-delete gtk) (connect-configure gtk) + (define saved-title (or label "")) + (define is-modified? #f) + (when label (gtk_window_set_title gtk label)) @@ -288,7 +291,10 @@ (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) - (define/public (set-modified mod?) (void)) + (define/public (set-modified mod?) + (unless (eq? is-modified? (and mod? #t)) + (set! is-modified? (and mod? #t)) + (set-title saved-title))) (define/public (create-status-line) (void)) (define/public (set-status-text s) (void)) @@ -334,6 +340,10 @@ (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) (def/public-unimplemented iconize) - (define/public (set-title s) - (gtk_window_set_title gtk s)))) + + (define/public (set-title s) + (set! saved-title s) + (gtk_window_set_title gtk (if is-modified? + (string-append s "*") + s))))) From 4c3749468d6a618cd6a9a48e339483d389ea7177 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 16:09:39 -0600 Subject: [PATCH 210/462] gtk clipboard fixes original commit: ed2c685a73f8b902126b5aa2a9f6825b1f35c73f --- collects/mred/private/wx/gtk/clipboard.rkt | 47 +++++++++++++--------- 1 file changed, 28 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 075890b9..f396badc 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -2,6 +2,7 @@ (require scheme/class scheme/foreign "../../syntax.rkt" + "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" "../common/bstr.rkt" @@ -41,7 +42,7 @@ (define-gtk gtk_selection_data_set (_fun _GtkSelectionData _GdkAtom _int - _ubyte + _bytes _int -> _void)) (define-gtk gtk_clipboard_wait_for_contents (_fun _GtkClipboard _GdkAtom -> (_or-null _GtkSelectionData))) @@ -62,7 +63,7 @@ (function-ptr get-data (_fun #:atomic? #t _GtkClipboard _GtkSelectionData _int _pointer -> _void))) (define (clear-owner cb self-box) - (send (ptr-ref self-box _scheme) replaced)) + (send (ptr-ref self-box _scheme) replaced self-box)) (define clear_owner (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) @@ -77,7 +78,7 @@ (if x-selection? (gdk_atom_intern "CLIPBOARD" #t) (gdk_atom_intern "PRIMARY" #t)))) - (define self-box (malloc-immobile-cell this)) + (define self-box #f) (define/public (get-client) client) @@ -107,25 +108,33 @@ (+ offset 1)))) (set! client c) (set! client-data all-data) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - self-box) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) + (free target-strings))))) - (define/public (replaced) + (define/public (replaced s-box) ;; Called in Gtk event-dispatch thread --- atomically with respect ;; to any other thread - (let ([c client]) - (when c - (set! client #f) - (set! client-data #f) - (queue-event (send c get-client-eventspace) - (lambda () - (send c on-replaced)))))) - + (when (eq? s-box self-box) + (set! self-box #f) + (let ([c client]) + (when c + (set! client #f) + (set! client-data #f) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))))) + (free-immobile-cell s-box)) + (define/public (provide-data i sel-data) ;; Called in Gtk event-dispatch thread --- atomically with respect ;; to any other thread @@ -150,7 +159,7 @@ (process (gtk_clipboard_wait_for_contents cb (gdk_atom_intern format #t))))) (define/public (get-text-data) - (gtk_clipboard_wait_for_text cb)) + (or (gtk_clipboard_wait_for_text cb) "")) (super-new)) From 0ebcd5678d97125a6eb724abedee55efbf8b95ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Sep 2010 19:27:46 -0600 Subject: [PATCH 211/462] add dc<%> copy method; speed text drawing a little and implement but disable editor scrolling with dc<%> copy original commit: 4bd84adb3afa20f3c95799b915ab6a042ea54c42 --- collects/mred/private/wxme/editor-canvas.rkt | 110 ++++++++++++++----- 1 file changed, 81 insertions(+), 29 deletions(-) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index cb492ed0..a9dca0e7 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -440,13 +440,14 @@ (let-boxes ([x 0] [y 0]) (get-scroll x y) - (let ([y (max (+ y + (let ([old-y y] + [y (max (+ y (* wheel-amt (if (eq? code 'wheel-up) -1 1))) 0)]) - (do-scroll x y #t))))] + (do-scroll x y #t x old-y))))] [else (when (and media (not (send media get-printing))) (using-admin @@ -490,7 +491,7 @@ (when (not (send media get-printing)) (let-boxes ([x 0][y 0][w 0][h 0]) (get-view x y w h) - (redraw x y w h))) + (redraw x y w h #f))) (let ([bg (get-canvas-background)]) (when bg (let ([adc (get-dc)]) @@ -538,28 +539,31 @@ (let-boxes ([x 0] [y 0]) (get-scroll x y) - (when fx - (set-box! fx (- (* x hpixels-per-scroll) xmargin))) - (when fy - (if (and media - (or (positive? y) - scroll-bottom-based?)) - (let ([v (- (if (send media locked-for-read?) - 0.0 - (send media scroll-line-location (+ y scroll-offset))) - ymargin)]) - (set-box! fy v) - (when (and scroll-bottom-based? - (or (positive? scroll-height) - scroll-to-last?)) - (let-boxes ([w 0] [h 0]) - (get-client-size w h) - (let ([h (max (- h (* 2 ymargin)) - 0)]) - (set-box! fy (- (unbox fy) h)))))) - (set-box! fy (- ymargin)))))) + (convert-scroll-to-location x y fx fy))) (get-dc)) + (define/private (convert-scroll-to-location x y fx fy) + (when fx + (set-box! fx (- (* x hpixels-per-scroll) xmargin))) + (when fy + (if (and media + (or (positive? y) + scroll-bottom-based?)) + (let ([v (- (if (send media locked-for-read?) + 0.0 + (send media scroll-line-location (+ y scroll-offset))) + ymargin)]) + (set-box! fy v) + (when (and scroll-bottom-based? + (or (positive? scroll-height) + scroll-to-last?)) + (let-boxes ([w 0] [h 0]) + (get-client-size w h) + (let ([h (max (- h (* 2 ymargin)) + 0)]) + (set-box! fy (- (unbox fy) h)))))) + (set-box! fy (- ymargin))))) + (define/public (get-view fx fy fw fh [unused-full? #f]) (let ([w (box 0)] [h (box 0)]) @@ -574,10 +578,21 @@ (when fw (set-box! fw (max 0 (- (unbox w) (* 2 xmargin))))))) - (define/public (redraw localx localy fw fh) + (define/public (redraw localx localy fw fh clear?) (when (and media (not (send media get-printing))) (begin-refresh-sequence) + (when clear? + (let ([bg (get-canvas-background)]) + (when bg + (let ([adc (get-dc)]) + (let ([b (send adc get-brush)] + [p (send adc get-pen)]) + (send adc set-brush bg 'solid) + (send adc set-pen bg 1 'transparent) + (send adc draw-rectangle localx localy fw fh) + (send adc set-brush b) + (send adc set-pen p)))))) (let ([x (box 0)] [y (box 0)] [w (box 0)] @@ -694,7 +709,7 @@ (send hscroll set-value sx)) (when vscroll (send vscroll set-value sy)) - (do-scroll sx sy refresh?) + (do-scroll sx sy refresh? cx cy) #t) #f))))))))) @@ -863,7 +878,7 @@ retval))))))) - (define/private (do-scroll x y refresh?) + (define/private (do-scroll x y refresh? old-x old-y) (let ([savenoloop? noloop?]) (set! noloop? #t) @@ -878,8 +893,45 @@ (set-scroll-pos 'vertical (->long (min y scroll-height))))) (set! noloop? savenoloop?) - - (when refresh? (repaint)))) + + (when refresh? + (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Gtk + (not need-refresh?) + (not lazy-refresh?) + (get-canvas-background) + (= x old-x)) ; could handle horizontal scrolling in the future + (let-boxes ([fx 0] + [old-fy 0] + [new-fy 0]) + (begin + (convert-scroll-to-location x y fx new-fy) + (convert-scroll-to-location old-x old-y #f old-fy)) + (let-boxes ([vx 0][vy 0][vw 0][vh 0]) + (get-view vx vy vw vh) ; editor coords + (cond + [(and (new-fy . < . old-fy) + (old-fy . < . (+ new-fy vh))) + (let ([dc (get-dc)]) + (send dc copy + xmargin ymargin + vw (- (+ new-fy vh) old-fy) + xmargin (+ ymargin (- old-fy new-fy))) + (redraw xmargin ymargin + vw (- old-fy new-fy) + #t))] + [(and (old-fy . < . new-fy) + (new-fy . < . (+ old-fy vh))) + (let ([dc (get-dc)]) + (send dc copy + xmargin (+ ymargin (- new-fy old-fy)) + vw (- (+ old-fy vh) new-fy) + xmargin ymargin) + (let ([d (- (+ old-fy vh) new-fy)]) + (redraw xmargin (+ ymargin d) + vw (- vh d) + #t)))] + [else (repaint)]))) + (repaint))))) (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void)) @@ -1113,7 +1165,7 @@ [is-shown? (if (not (send canvas get-canvas-background)) (send canvas repaint) - (send canvas redraw localx localy w h))])))) + (send canvas redraw localx localy w h #f))])))) (define/override (resized update?) (all-in-chain (lambda (a) (send a do-resized update?)))) From 0b03ac334571ed61788483c1b8816576cfdccb96 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 06:20:45 -0600 Subject: [PATCH 212/462] adjust flush-display original commit: 61788d68d513ddbbc4d0e4703f54e66b5849031d --- collects/framework/splash.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/window.rkt | 9 +++++++++ collects/mred/private/wx/gtk/window.rkt | 9 ++++----- 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 5c7b3ba6..9bb519ec 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -157,6 +157,7 @@ (refresh-splash) (send splash-tlw center 'both) (thread (λ () (send splash-tlw show #t))) + (sync (system-idle-evt)) ; try to wait for dialog to be shown (flush-display) (yield) (sleep) (flush-display) (yield) (sleep))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 90e394c7..91f3f9d1 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -7,6 +7,7 @@ "utils.rkt" "types.rkt" "frame.rkt" + "window.rkt" "finfo.rkt" ; file-creator-and-type "filedialog.rkt" "../../lock.rkt" @@ -93,7 +94,6 @@ (define (get-control-font-size) 13) (define (cancel-quit) (void)) (define-unimplemented fill-private-color) -(define (flush-display) (void)) (define-unimplemented write-resource) (define-unimplemented get-resource) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 033f8da7..d89757db 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -32,6 +32,7 @@ request-flush-delay cancel-flush-delay make-init-point + flush-display special-control-key special-option-key) @@ -504,6 +505,9 @@ ;; events (e.g., key repeat) have a corresponding ;; stream of screen updates. (try-to-sync-refresh) + (flush)) + + (define/public (flush) (let ([cocoa-win (get-cocoa-window)]) (when cocoa-win (tellv cocoa-win displayIfNeeded) @@ -676,3 +680,8 @@ (if (= y -11111) 0 y))) + +(define (flush-display) + (try-to-sync-refresh) + (for ([win (in-list (get-top-level-windows))]) + (send win flush))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b6a00d61..ef295165 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -530,8 +530,6 @@ ;; re-sync the display in case a stream of ;; events (e.g., key repeat) have a corresponding ;; stream of screen updates. - (try-to-sync-refresh) - (gdk_window_process_all_updates) (flush-display)) (define/public (handles-events? gtk) #f) @@ -612,10 +610,11 @@ (queue-refresh-event (send win get-eventspace) thunk)) (define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) -(define-gdk gdk_display_sync (_fun _GdkDisplay -> _void)) (define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) -(define (flush-display) (gdk_display_flush (gdk_display_get_default))) -(define (sync-display) (gdk_display_sync (gdk_display_get_default))) +(define (flush-display) + (try-to-sync-refresh) + (gdk_window_process_all_updates) + (gdk_display_flush (gdk_display_get_default))) (define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) (define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) From 4babb2653371f989e0976216628abbbc269bc68a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 07:52:22 -0600 Subject: [PATCH 213/462] fix gtk collecting blit to revert immediately when gc ends original commit: bff39a1832548796a06e58d0810827b89a5bc984 --- collects/mred/private/wx/gtk/canvas.rkt | 38 +++++++++++--------- collects/mred/private/wx/gtk/gcwin.rkt | 27 +++++++++----- collects/scribblings/gui/miscwin-funcs.scrbl | 7 ++-- 3 files changed, 43 insertions(+), 29 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 26200fcd..044f6f14 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -595,29 +595,33 @@ (define reg-blits null) - (define/private (register-one-blit x y w h pixbuf) + (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) (let* ([cwin (widget-window client-gtk)]) (atomically - (let ([win (create-gc-window cwin x y w h pixbuf)]) + (let ([win (create-gc-window cwin x y w h)]) (let ([r (scheme_add_gc_callback - (make-gc-show-desc win pixbuf w h) - (make-gc-hide-desc win))]) + (make-gc-show-desc win on-pixbuf w h) + (make-gc-hide-desc win off-pixbuf w h))]) (cons win r)))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([on (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm)))]) - (let ([pixbuf (bitmap->pixbuf on)]) - (atomically - (set! reg-blits (cons (register-one-blit x y w h pixbuf) reg-blits)))))) + (let ([fix-size (lambda (on on-x on-y) + (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm))))]) + (let ([on (fix-size on on-x on-y)] + [off (fix-size off off-x off-y)]) + (let ([on-pixbuf (bitmap->pixbuf on)] + [off-pixbuf (bitmap->pixbuf off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) (define/public (unregister-collecting-blits) (atomically diff --git a/collects/mred/private/wx/gtk/gcwin.rkt b/collects/mred/private/wx/gtk/gcwin.rkt index 94ee1b26..49701b74 100644 --- a/collects/mred/private/wx/gtk/gcwin.rkt +++ b/collects/mred/private/wx/gtk/gcwin.rkt @@ -54,7 +54,7 @@ (define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) (define-mz scheme_remove_gc_callback (_fun _racket -> _void)) -(define (create-gc-window cwin x y w h pixbuf) +(define (create-gc-window cwin x y w h) (let ([win (gdk_window_new cwin (make-GdkWindowAttr "" 0 @@ -68,16 +68,27 @@ GDK_WA_Y))]) win)) +(define (make-draw win pixbuf w h) + (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void + gdk_draw_pixbuf + win #f pixbuf + 0 0 0 0 w h + 0 0 0)) + +(define (make-flush) + (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f)) + (define (make-gc-show-desc win pixbuf w h) (vector (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f) - (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void - gdk_draw_pixbuf - win #f pixbuf - 0 0 0 0 w h - 0 0 0) - (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))) + (make-draw win pixbuf w h) + (make-flush))) -(define (make-gc-hide-desc win) +(define (make-gc-hide-desc win pixbuf w h) (vector + ;; draw the ``off'' bitmap so we can flush immediately + (make-draw win pixbuf w h) + (make-flush) + ;; hide the window; it may take a while for the underlying canvas + ;; to refresh: (vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f))) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 5938b1cc..56a436e9 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -337,16 +337,15 @@ Registers a ``blit'' to occur when garbage collection starts and ends. When garbage collection starts, @racket[on] is drawn at location @racket[x] and @racket[y] within @racket[canvas], if @racket[canvas] is shown. When garbage collection ends, the drawing - is reverted. The @racket[off], @racket[off-x], and @racket[off-y] - arguments are currently unused, though they were formerly used to - revert the drawing of @racket[on]. + is reverted, possibly by drawing the @racket[off] bitmap. The background behind @racket[on] is unspecified, so @racket[on] should be a solid image, and the canvas's scale or scrolling is not applied to the drawing. Only the portion of @racket[on] within @racket[w] and @racket[h] pixels is used; if @racket[on-x] and @racket[on-y] are specified, they specify an offset within the bitmap - that is used for drawing. + that is used for drawing, and @racket[off-x] and @racket[off-y] + similarly specify an offset within @racket[off]. The blit is automatically unregistered if @scheme[canvas] becomes invisible and inaccessible. Multiple registrations can be installed From 5c533a1695a0830f927f0877361a53b324df4253 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 14:19:35 -0600 Subject: [PATCH 214/462] add make-screen-bitmap and canvas% make-bitmap; specialize for X11 original commit: 51aacfe949cfd30dea4c37dc5d3c376edcb29ff7 --- collects/mred/mred-sig.rkt | 1 + collects/mred/mred.rkt | 3 +- collects/mred/private/mrcanvas.rkt | 15 ++++++++ collects/mred/private/wx/cocoa/canvas.rkt | 3 ++ collects/mred/private/wx/cocoa/dc.rkt | 25 ++++++------ collects/mred/private/wx/cocoa/platform.rkt | 3 +- collects/mred/private/wx/cocoa/procs.rkt | 8 +++- .../mred/private/wx/common/backing-dc.rkt | 20 +++++----- collects/mred/private/wx/gtk/canvas.rkt | 9 ++++- collects/mred/private/wx/gtk/dc.rkt | 38 ++++++++++++++++++- collects/mred/private/wx/gtk/platform.rkt | 3 +- collects/mred/private/wx/gtk/procs.rkt | 10 ++++- collects/mred/private/wx/gtk/x11.rkt | 35 +++++++++++++++++ collects/mred/private/wx/platform.rkt | 3 +- collects/mred/private/wx/win32/platform.rkt | 3 +- collects/mred/private/wx/win32/procs.rkt | 5 ++- collects/mred/private/wxme/editor-canvas.rkt | 2 +- collects/scribblings/gui/canvas-class.scrbl | 28 ++++++++++++++ collects/scribblings/gui/miscwin-funcs.scrbl | 12 ++++++ doc/release-notes/racket/Draw_and_GUI_5_5.txt | 12 ++++++ 20 files changed, 203 insertions(+), 35 deletions(-) create mode 100644 collects/mred/private/wx/gtk/x11.rkt diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 7f41132b..72d97f8b 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -122,6 +122,7 @@ list-control<%> make-eventspace make-gui-empty-namespace make-gui-namespace +make-screen-bitmap map-command-as-meta-key menu% menu-bar% diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 2fc3ba91..65be0c5a 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -194,7 +194,8 @@ the-pen-list the-brush-list the-style-list - the-editor-wordbreak-map) + the-editor-wordbreak-map + make-screen-bitmap) (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index b99d8496..2da1e177 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -51,6 +51,21 @@ [warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))] [get-dc (entry-point (lambda () (send wx get-dc)))] + [make-bitmap (lambda (w h) + (unless (exact-positive-integer? w) + (raise-type-error (who->name '(method canvas% make-bitmap)) + "exact positive integer" + w)) + (unless (exact-positive-integer? h) + (raise-type-error (who->name '(method canvas% make-bitmap)) + "exact positive integer" + h)) + (send wx make-compatible-bitmap w h))] + + [suspend-flush (lambda () + (send wx begin-refresh-sequence))] + [resume-flush (lambda () + (send wx end-refresh-sequence))] [set-canvas-background (entry-point diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index a29c47d6..1c0b2fba 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -319,6 +319,9 @@ (define/public (get-dc) dc) + (define/public (make-compatible-bitmap w h) + (make-object quartz-bitmap% w h)) + (define/override (fix-dc [refresh? #t]) (when (dc . is-a? . dc%) (send dc reset-backing-retained) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 00aa41d2..7621a639 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -3,6 +3,7 @@ ffi/unsafe ffi/unsafe/objc racket/draw/cairo + racket/draw/bitmap racket/draw/local "types.rkt" "utils.rkt" @@ -13,28 +14,26 @@ "cg.rkt") (provide dc% + quartz-bitmap% do-backing-flush) (define quartz-bitmap% - (class object% - (init w h b&w? alpha?) - (super-new) + (class bitmap% + (init w h) + (super-make-object (make-alternate-bitmap-kind w h)) + (define s (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32 w h)) - (define/public (ok?) #t) - (define/public (is-color?) #t) + (define/override (ok?) #t) + (define/override (is-color?) #t) - (define width w) - (define height h) - (define/public (get-width) width) - (define/public (get-height) height) - - (define/public (get-cairo-surface) s) + (define/override (get-cairo-surface) s) + (define/override (get-cairo-alpha-surface) s) - (define/public (release-bitmap-storage) + (define/override (release-bitmap-storage) (atomically (cairo_surface_destroy s) (set! s #f))))) @@ -47,7 +46,7 @@ (super-new) ;; Use a quartz bitmap so that text looks good: - (define/override (get-bitmap%) quartz-bitmap%) + (define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h)) (define/override (can-combine-text? sz) #t) (define/override (get-backing-size xb yb) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 79f16367..1160f908 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -101,4 +101,5 @@ special-option-key special-control-key get-highlight-background-color - get-highlight-text-color)) + get-highlight-text-color + make-screen-bitmap)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 91f3f9d1..a4f6e049 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -10,6 +10,7 @@ "window.rkt" "finfo.rkt" ; file-creator-and-type "filedialog.rkt" + "dc.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -58,7 +59,8 @@ show-print-setup can-show-print-setup? get-highlight-background-color - get-highlight-text-color) + get-highlight-text-color + make-screen-bitmap) (import-class NSScreen NSCursor) @@ -119,6 +121,10 @@ (define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (make-object quartz-bitmap% w h)) + ;; ------------------------------------------------------------ ;; Text & highlight color diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 4d5e71b2..c77f6173 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -16,7 +16,7 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap% + make-backing-bitmap request-delay cancel-delay end-delay) @@ -28,7 +28,7 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap% + make-backing-bitmap request-delay cancel-delay end-delay) @@ -95,7 +95,8 @@ (log-error "unbalanced end-on-paint") (set! retained-counter (sub1 retained-counter)))))) - (define/public (get-bitmap%) bitmap%) + (define/public (make-backing-bitmap w h) + (make-object bitmap% w h #f #t)) (define/public (ensure-ready) (get-cr)) @@ -104,7 +105,7 @@ (let ([w (box 0)] [h (box 0)]) (get-backing-size w h) - (let ([bm (get-backing-bitmap (get-bitmap%) (unbox w) (unbox h))]) + (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))]) (internal-set-bitmap bm #t)) (let ([cr (super get-cr)]) (set! retained-cr cr) @@ -130,9 +131,10 @@ (define/override (resume-flush) (atomically - (set! flush-suspends (sub1 flush-suspends)) - (when (zero? flush-suspends) - (queue-backing-flush)))) + (unless (zero? flush-suspends) + (set! flush-suspends (sub1 flush-suspends)) + (when (zero? flush-suspends) + (queue-backing-flush))))) (define/public (end-delay) ;; call in atomic mode @@ -140,8 +142,8 @@ (cancel-delay req) (set! req #f))))) -(define (get-backing-bitmap bitmap% w h) - (make-object bitmap% w h #f #t)) +(define (get-backing-bitmap make-bitmap w h) + (make-bitmap w h)) (define (release-backing-bitmap bm) (send bm release-bitmap-storage)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 044f6f14..9730682d 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -328,6 +328,9 @@ (define/public (get-dc) dc) + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h #t)) + (define/override (get-client-gtk) client-gtk) (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) @@ -380,8 +383,10 @@ (define/public (get-flush-window) client-gtk) - (define/public (begin-refresh-sequence) (void)) - (define/public (end-refresh-sequence) (void)) + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) (define/override (refresh) (queue-paint)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 6907353d..98009bbf 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -4,19 +4,48 @@ "utils.rkt" "types.rkt" "window.rkt" + "x11.rkt" "../../lock.rkt" "../common/backing-dc.rkt" racket/draw/cairo racket/draw/dc + racket/draw/bitmap racket/draw/local ffi/unsafe/alloc) (provide dc% - do-backing-flush) + do-backing-flush + x11-bitmap%) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) +(define x11-bitmap% + (class bitmap% + (init w h gdk-win) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define pixmap (gdk_pixmap_new gdk-win w h (if gdk-win -1 24))) + (define s + (cairo_xlib_surface_create (gdk_x11_display_get_xdisplay + (gdk_drawable_get_display pixmap)) + (gdk_x11_drawable_get_xid pixmap) + (gdk_x11_visual_get_xvisual + (gdk_drawable_get_visual pixmap)) + w + h)) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (gobject-unref pixmap) + (set! s #f))))) + (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -24,6 +53,13 @@ (super-new) + (define/override (make-backing-bitmap w h [any-bg? #f]) + (if (and (or any-bg? + (send canvas get-canvas-background)) + (eq? 'unix (system-type))) + (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk))) + (super make-backing-bitmap w h))) + (define/override (get-backing-size xb yb) (send canvas get-client-size xb yb)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 2bc65319..f20c1811 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -101,4 +101,5 @@ special-option-key special-control-key get-highlight-background-color - get-highlight-text-color)) + get-highlight-text-color + make-screen-bitmap)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 96162e9d..99cfbf55 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -10,6 +10,7 @@ "style.rkt" "widget.rkt" "window.rkt" + "dc.rkt" "../common/handlers.rkt") (provide @@ -60,7 +61,8 @@ show-print-setup can-show-print-setup? get-highlight-background-color - get-highlight-text-color) + get-highlight-text-color + make-screen-bitmap) (define-unimplemented special-control-key) (define (special-option-key on?) (void)) @@ -132,3 +134,9 @@ (if (and (zero? r) (zero? g) (zero? b)) #f (make-object color% r g b)))) + +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (if (eq? 'unix (system-type)) + (make-object x11-bitmap% w h #f) + (make-object bitmap% w h #f #t))) diff --git a/collects/mred/private/wx/gtk/x11.rkt b/collects/mred/private/wx/gtk/x11.rkt new file mode 100644 index 00000000..dce8ea4c --- /dev/null +++ b/collects/mred/private/wx/gtk/x11.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + "utils.rkt") + +(provide gdk_pixmap_new + gdk_drawable_get_display + gdk_drawable_get_visual + gdk_x11_drawable_get_xid + gdk_x11_display_get_xdisplay + gdk_x11_visual_get_xvisual) + +(define _GdkDrawable _pointer) +(define _GdkDisplay (_cpointer 'GdkDisplay)) +(define _GdkVisual (_cpointer 'GdkVisual)) +(define _GdkPixmap (_cpointer 'GdkPixmap)) +(define _Visual (_cpointer 'Visual)) +(define _Display (_cpointer 'Display)) +(define _Drawable _ulong) + +(define-gdk gdk_pixmap_new (_fun _GdkDrawable _int _int _int -> _GdkPixmap) + #:wrap (allocator gobject-unref)) + +(define-gdk gdk_drawable_get_display (_fun _GdkDrawable -> _GdkDisplay)) +(define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual)) + +(define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable) + #:make-fail make-not-available) + +(define-gdk gdk_x11_display_get_xdisplay (_fun _GdkDisplay -> _Display) + #:make-fail make-not-available) + +(define-gdk gdk_x11_visual_get_xvisual (_fun _GdkVisual -> _Visual) + #:make-fail make-not-available) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 3f5842a5..53f1e0f0 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -79,5 +79,6 @@ special-option-key special-control-key get-highlight-background-color - get-highlight-text-color) + get-highlight-text-color + make-screen-bitmap) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 61d922b7..94abbf66 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -100,4 +100,5 @@ special-option-key special-control-key get-highlight-background-color - get-highlight-text-color)) + get-highlight-text-color + make-screen-bitmap)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 844fbca4..ecb0535c 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -49,8 +49,8 @@ show-print-setup can-show-print-setup? get-highlight-background-color - get-highlight-text-color) - + get-highlight-text-color + make-screen-bitmap) (define-unimplemented special-control-key) (define-unimplemented special-option-key) @@ -103,3 +103,4 @@ (define-unimplemented can-show-print-setup?) (define-unimplemented get-highlight-background-color) (define-unimplemented get-highlight-text-color) +(define-unimplemented make-screen-bitmap) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index a9dca0e7..521d9cfb 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -895,7 +895,7 @@ (set! noloop? savenoloop?) (when refresh? - (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Gtk + (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Windows (not need-refresh?) (not lazy-refresh?) (get-canvas-background) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 5f3ef186..07b710d3 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -248,6 +248,13 @@ See also } +@defmethod[(make-bitmap [width exact-positive-integer?] + [height exact-positive-integer?]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that draws in a way that is the same as drawing to the +canvas. See also @racket[make-screen-bitmap].} + @defmethod[#:mode override (on-paint) @@ -273,6 +280,11 @@ This method is called only when manual } +@defmethod[(resume-flush) void?]{ + +See @method[canvas% suspend-flush].} + + @defmethod[(scroll [h-value (or/c (real-in 0.0 1.0) false/c)] [v-value (or/c (real-in 0.0 1.0) false/c)]) void?]{ @@ -373,6 +385,22 @@ init-manual-scrollbars]. } +@defmethod[(suspend-flush) void?]{ + +Drawing to a canvas's drawing context actually renders into an +offscreen buffer. The buffer is automatically flushed to the screen by +a background thread, unless flushing has been disabled for the canvas. +The @method[canvas% suspend-flush] method suspends flushing for a +canvas until a matching @method[canvas% resume-flush] calls; calls to +@method[canvas% suspend-flush] and @method[canvas% resume-flush] can +be nested, in which case flushing is suspended until the outermost +@method[canvas% suspend-flush] is balanced by a @method[canvas% +resume-flush]. + +On some platforms, beware that suspending flushing for a canvas can +discourage refreshes for other windows in the same frame.} + + @defmethod[(swap-gl-buffers) void?]{ Calls diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 56a436e9..2419d8d6 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -289,6 +289,18 @@ Like @racket[make-base-namespace], but with @racketmodname[racket/class] and environment of the result namespace.} +@defproc[(make-screen-bitmap [width exact-positive-integer?] + [height exact-positive-integer?]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that draws in a way that is the same as drawing to a +canvas in its default configuration. The bitmap is always in color +with an alpha channel. + +A normal @racket[bitmap%] draws in a more platform-independent way and +may use fewer constrained resources, particularly under Windows.} + + @defproc[(play-sound [filename path-string?] [async? any/c]) boolean?]{ diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index 5ac70809..b56ac8d6 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -8,6 +8,18 @@ Changes to the drawing toolbox: The `racket/draw' library is built on top of the widely used Cairo drawing library and Pango text-rendering library. + * Drawing to a bitmap may not produce the same results as drawing to + a canvas. Use the `make-screen-bitmap' function (from `racket/gui') + or the `make-bitmap' method of `canvas%' to obtain a bitmap that + uses the same drawing algorithms as a canvas. + + Drawing to a canvas always draws into a bitmap that is kept + offscreen and periodically flushed onto the screen. The new + `suspend-flush' and `resume-fluah' methods of `canvas%' provide + some control over the timing of the flushes, which in many cases + avoids the need for (additional) double buffering of canvas + content. + * A color bitmap can have an alpha channel, instead of just a mask bitmap. When drawing a bitmap, alpha channels are used more consistently and automatically than mask bitmaps. More From 5eee7343aa99919e88b0d555fad40c01d6e77a95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 15:13:55 -0600 Subject: [PATCH 215/462] gtk win32 canvas back-end original commit: d094fff51e578b7d6c12eca8bbd4a0ca87ca2480 --- collects/mred/private/wx/gtk/dc.rkt | 43 +++++++++++++++++++++++--- collects/mred/private/wx/gtk/win32.rkt | 26 ++++++++++++++++ 2 files changed, 64 insertions(+), 5 deletions(-) create mode 100644 collects/mred/private/wx/gtk/win32.rkt diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 98009bbf..46c1c0c3 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -5,6 +5,7 @@ "types.rkt" "window.rkt" "x11.rkt" + "win32.rkt" "../../lock.rkt" "../common/backing-dc.rkt" racket/draw/cairo @@ -46,6 +47,32 @@ (gobject-unref pixmap) (set! s #f))))) +(define win32-bitmap% + (class bitmap% + (init w h gdk-win) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define s + (if gdk-win + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hdc)))))) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -54,11 +81,17 @@ (super-new) (define/override (make-backing-bitmap w h [any-bg? #f]) - (if (and (or any-bg? - (send canvas get-canvas-background)) - (eq? 'unix (system-type))) - (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk))) - (super make-backing-bitmap w h))) + (cond + [(and (eq? 'unix (system-type)) + (or any-bg? + (send canvas get-canvas-background))) + (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))] + [(and (eq? 'windows (system-type)) + (or any-bg? + (send canvas get-canvas-background))) + (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] + [else + (super make-backing-bitmap w h)])) (define/override (get-backing-size xb yb) (send canvas get-client-size xb yb)) diff --git a/collects/mred/private/wx/gtk/win32.rkt b/collects/mred/private/wx/gtk/win32.rkt new file mode 100644 index 00000000..a7414899 --- /dev/null +++ b/collects/mred/private/wx/gtk/win32.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "utils.rkt") + +(provide gdk_win32_drawable_get_handle + GetDC + ReleaseDC) + +(define user32-lib + (cond + [(eq? 'windows (system-type)) + (ffi-lib "user32.dll")] + [else #f])) + +(define-ffi-definer define-user32 user32-lib) + +(define _GdkDrawable _pointer) + +(define-gdk gdk_win32_drawable_get_handle (_fun _GdkDrawable -> _pointer) + #:make-fail make-not-available) + +(define-user32 GetDC (_fun #:abi 'stdcall _pointer -> _pointer) + #:make-fail make-not-available) +(define-user32 ReleaseDC (_fun #:abi 'stdcall _pointer -> _void) + #:make-fail make-not-available) From 1be1ffcda53f520501ee10c70ecc2f5aa314b2e3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 16:30:44 -0600 Subject: [PATCH 216/462] cocoa cechkable menu repairs original commit: d920342fa16664b414e8ac1890523cd13c145a12 --- collects/mred/private/wx/cocoa/menu-item.rkt | 19 ++++++++++++++++--- collects/mred/private/wx/cocoa/menu.rkt | 8 ++++---- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index fc8e75df..5495e00e 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -18,7 +18,11 @@ (-a _void (selected: [_id sender]) (let ([wx (->wx wxb)]) (when wx - (send wx selected))))) + (send wx selected)))) + (-a _void (selectedCheckable: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx + (send wx selected-checkable self))))) (defclass menu-item% object% @@ -28,6 +32,11 @@ (define/public (selected) ;; called in Cocoa thread (send parent item-selected this)) + (define/public (selected-checkable cocoa) + ;; called in Cocoa thread + (set! checked? (not checked?)) + (tellv cocoa setState: #:type _int (if checked? 1 0)) + (send parent item-selected this)) (define/public (set-parent p) (set! parent p)) @@ -47,7 +56,7 @@ (define submenu #f) (define/public (set-submenu m) (set! submenu m)) - (define/public (install menu) + (define/public (install menu checkable?) (if submenu (send submenu install menu label enabled?) (let ([item (as-objc-allocation @@ -58,8 +67,12 @@ (set-ivar! item wxb (->wxb this)) (tellv menu addItem: item) (tellv item setEnabled: #:type _BOOL enabled?) + (when checked? + (tellv item setState: #:type _int 1)) (tellv item setTarget: item) - (tellv item setAction: #:type _SEL (selector selected:)) + (tellv item setAction: #:type _SEL (if checkable? + (selector selectedCheckable:) + (selector selected:))) (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) (when shortcut (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index a671fffd..422554f9 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -15,7 +15,7 @@ (import-class NSMenu NSMenuItem) -(define-struct mitem (item)) +(define-struct mitem (item checkable?)) (defclass menu% object% (init-field label @@ -45,7 +45,7 @@ (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) (if item - (send (mitem-item item) install cocoa-menu) + (send (mitem-item item) install cocoa-menu (mitem-checkable? item)) (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) items))) @@ -100,10 +100,10 @@ (when (help-str-or-submenu . is-a? . menu%) (send i set-submenu help-str-or-submenu) (send help-str-or-submenu set-parent this)) - (set! items (append items (list (make-mitem i)))) + (set! items (append items (list (make-mitem i chckable?)))) (send i set-parent this) (when cocoa-menu - (send i install cocoa-menu))) + (send i install cocoa-menu chckable?))) (define/public (append-separator) (set! items (append items (list #f))) From 02e931391d783c08e5e9bc65d8e339f48d758e2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 16:31:04 -0600 Subject: [PATCH 217/462] screen dc corrections and clarifications original commit: 5ebfa781bdc4a6ee9bf41f01cef1c76dde36e78c --- collects/mred/private/wx/gtk/canvas.rkt | 2 +- collects/mred/private/wx/gtk/dc.rkt | 9 ++++----- collects/scribblings/gui/miscwin-funcs.scrbl | 3 +-- 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 9730682d..96a13b69 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -329,7 +329,7 @@ (define/public (get-dc) dc) (define/public (make-compatible-bitmap w h) - (send dc make-backing-bitmap w h #t)) + (send dc make-backing-bitmap w h)) (define/override (get-client-gtk) client-gtk) (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 46c1c0c3..01a141a2 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -38,6 +38,7 @@ (define/override (ok?) #t) (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) (define/override (get-cairo-surface) s) @@ -80,15 +81,13 @@ (super-new) - (define/override (make-backing-bitmap w h [any-bg? #f]) + (define/override (make-backing-bitmap w h) (cond [(and (eq? 'unix (system-type)) - (or any-bg? - (send canvas get-canvas-background))) + (send canvas get-canvas-background)) (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))] [(and (eq? 'windows (system-type)) - (or any-bg? - (send canvas get-canvas-background))) + (send canvas get-canvas-background)) (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] [else (super make-backing-bitmap w h)])) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 2419d8d6..bcd3e71d 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -294,8 +294,7 @@ environment of the result namespace.} (is-a/c? bitmap%)]{ Creates a bitmap that draws in a way that is the same as drawing to a -canvas in its default configuration. The bitmap is always in color -with an alpha channel. +canvas in its default configuration. A normal @racket[bitmap%] draws in a more platform-independent way and may use fewer constrained resources, particularly under Windows.} From 8bd418695fb8bed3a94b33c2303fc55f25a00c77 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 18:00:30 -0600 Subject: [PATCH 218/462] fix slider value display and 'plain option original commit: 5809bc7790249e9cd5debfb29d09097189f9bcea --- collects/mred/private/wx/cocoa/queue.rkt | 3 +- collects/mred/private/wx/cocoa/slider.rkt | 123 ++++++++++++++++++---- collects/mred/private/wx/gtk/slider.rkt | 4 + collects/tests/gracket/item.rkt | 12 ++- 4 files changed, 113 insertions(+), 29 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9b2c2fea..3557c15f 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -259,8 +259,7 @@ (define (try-to-sync-refresh) (atomically - (pre-event-sync #t) - (check-one-event #f #f))) + (pre-event-sync #t))) ;; ------------------------------------------------------------ ;; Install an alternate "sleep" function (in the PLT Scheme core) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 246d402d..477cd96d 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -19,7 +19,7 @@ ;; ---------------------------------------- -(import-class NSSlider) +(import-class NSSlider NSTextField NSView) (define-objc-class MySlider NSSlider #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) @@ -27,6 +27,7 @@ (-a _void (changed: [_id sender]) (let ([wx (->wx wxb)]) (when wx + (send wx update-message) (queue-window-event wx (lambda () (send wx changed))) (constrained-reply (send wx get-eventspace) @@ -40,31 +41,104 @@ x y w style font) - (inherit get-cocoa register-as-child) + (inherit get-cocoa register-as-child + init-font) + + (define vert? (memq 'vertical style)) + + (define slider-cocoa + (let ([cocoa (as-objc-allocation + (tell (tell MySlider alloc) init))]) + (tellv cocoa setMinValue: #:type _double* lo) + (tellv cocoa setMaxValue: #:type _double* hi) + (tellv cocoa setDoubleValue: #:type _double* val) + (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) + (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (if vert? 24 32) + (if vert? 64 24)))) + (tellv cocoa setContinuous: #:type _BOOL #t) + ;; (tellv cocoa sizeToFit) + cocoa)) + + (define-values (message-cocoa message-w message-h) + (if (memq 'plain style) + (values #f #f #f) + (let ([cocoa (as-objc-allocation + (tell (tell NSTextField alloc) init))]) + (init-font cocoa font) + (tellv cocoa setSelectable: #:type _BOOL #f) + (tellv cocoa setEditable: #:type _BOOL #f) + (tellv cocoa setBordered: #:type _BOOL #f) + (tellv cocoa setDrawsBackground: #:type _BOOL #f) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" hi)) + (tellv cocoa sizeToFit) + (let ([r1 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" lo)) + (tellv cocoa sizeToFit) + (let ([r2 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)) + (values cocoa + (max (NSSize-width (NSRect-size r1)) + (NSSize-width (NSRect-size r2))) + (max (NSSize-height (NSRect-size r1)) + (NSSize-height (NSRect-size r2))))))))) + + (define cocoa + (if message-cocoa + (let* ([f (tell #:type _NSRect slider-cocoa frame)] + [w (+ (if vert? + message-w + 0) + (NSSize-width (NSRect-size f)))] + [h (+ (if vert? + 0 + message-h) + (NSSize-height (NSRect-size f)))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-init-point x y) + (make-NSSize w h))))]) + (tellv cocoa addSubview: slider-cocoa) + (tellv cocoa addSubview: message-cocoa) + (arrange-parts w h) + cocoa)) + slider-cocoa)) + + (define/private (arrange-parts w h) + (tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 + (if vert? 0 message-h)) + (make-NSSize (- w (if vert? message-w 0)) + (- h (if vert? 0 message-h))))) + (tellv message-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint (if vert? + (- w message-w) + (/ (- w message-w) 2)) + (if vert? + (/ (- h message-h) 2) + 0)) + (make-NSSize message-w message-h)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when message-cocoa + (arrange-parts w h))) + + (when message-cocoa + (set-ivar! slider-cocoa wxb (->wxb this))) (super-new [parent parent] - [cocoa (let ([cocoa (as-objc-allocation - (tell (tell MySlider alloc) init))] - [vert? (memq 'vertical style)]) - (tellv cocoa setMinValue: #:type _double* lo) - (tellv cocoa setMaxValue: #:type _double* hi) - (tellv cocoa setDoubleValue: #:type _double* val) - (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) - (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (if vert? 24 32) - (if vert? 64 24)))) - (tellv cocoa setContinuous: #:type _BOOL #t) - ; (tellv cocoa sizeToFit) - cocoa)] + [cocoa cocoa] [callback cb] [no-show? (memq 'deleted style)]) - (define cocoa (get-cocoa)) + (define/override (get-cocoa-control) slider-cocoa) - (tellv cocoa setTarget: cocoa) - (tellv cocoa setAction: #:type _SEL (selector changed:)) + (tellv slider-cocoa setTarget: slider-cocoa) + (tellv slider-cocoa setAction: #:type _SEL (selector changed:)) (define callback cb) (define/public (changed) @@ -74,9 +148,14 @@ (define/public (set-value v) - (tellv cocoa setDoubleValue: #:type _double* v)) + (atomically + (tellv slider-cocoa setDoubleValue: #:type _double* v) + (update-message v))) (define/public (get-value) - (inexact->exact (floor (tell #:type _double cocoa doubleValue)))) + (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue)))) + + (define/public (update-message [val (get-value)]) + (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index edcf5ad9..c2888a25 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -21,6 +21,7 @@ (define-gtk gtk_range_set_increments (_fun _GtkWidget _double* _double* -> _void)) (define-gtk gtk_range_set_value (_fun _GtkWidget _double* -> _void)) (define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) +(define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void)) (define-signal-handler connect-changed "value-changed" (_fun _GtkWidget -> _void) @@ -51,6 +52,9 @@ (gtk_range_set_increments gtk 1.0 1.0) (gtk_range_set_value gtk val) + (when (memq 'plain style) + (gtk_scale_set_draw_value gtk #f)) + (set-auto-size) (connect-changed gtk) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 0027c1cd..e8bd6f9a 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1561,7 +1561,7 @@ (instructions p "choice-list-steps.txt") (send f show #t)) -(define (slider-frame) +(define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) (define old-list null) @@ -1570,7 +1570,8 @@ (lambda (sl e) (check-callback-event s sl e commands #f) (printf "slid: ~a\n" (send s get-value))) - 3)) + 3 + (cons 'horizontal style))) (define c (make-object button% "Check" p (lambda (c e) (for-each @@ -2168,17 +2169,18 @@ (send gsp stretchable-height #f) (make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame))) (make-object vertical-pane% gsp) ; filler -(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame))) +(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null))) +(make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain)))) (make-object vertical-pane% gsp) ; filler (make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f))) (make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t))) -(make-object vertical-pane% gsp) ; filler -(make-object button% "Make Modified Frame" gsp (lambda (b e) (test-modified-frame))) (define tp (make-object horizontal-pane% ap)) (send tp stretchable-width #f) (make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single)))) (make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple)))) +(make-object vertical-pane% tp) ; filler +(make-object button% "Make Modified Frame" tp (lambda (b e) (test-modified-frame))) (define cnp (make-object horizontal-pane% ap)) (send cnp stretchable-width #t) From e0f1ae3ed9743b59c405d9a9e68495246006feb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Sep 2010 05:14:05 -0600 Subject: [PATCH 219/462] enable scrolling to extra tabs in a tabl panel original commit: 4d03f3ab3c417f9967db1950cf577505bf8d87e3 --- collects/mred/private/wx/gtk/tab-panel.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index b0985916..75ad7e1d 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -19,6 +19,7 @@ (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_notebook_set_scrollable (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) @@ -52,6 +53,8 @@ ;; Reparented so that it's always in the current page's bin: (define client-gtk (gtk_fixed_new)) + (gtk_notebook_set_scrollable gtk #t) + (super-new [parent parent] [gtk gtk] [client-gtk client-gtk] From 0b412d18d5538442da46aa86d497d2edade1a8ed Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Sep 2010 05:33:10 -0600 Subject: [PATCH 220/462] fix queue-callback to default to high priority original commit: 73d28a3fff66aae7c948aaf5d6f7adee809d4fc2 --- collects/mred/private/wx/common/queue.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 700b1c83..452528fc 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -408,7 +408,7 @@ (define (main-eventspace? e) (eq? e main-eventspace)) -(define (queue-callback thunk [high? #f]) +(define (queue-callback thunk [high? #t]) (queue-event (current-eventspace) thunk (cond [(not high?) 'lo] [(eq? high? middle-queue-key) 'med] From 061d523adf960448ecbed5a2c5e3efbb46ab0a88 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Sep 2010 07:04:48 -0600 Subject: [PATCH 221/462] unify cocoa & gtk canvas-painting implementation original commit: f40e7edae886dc09f8bbb979911fd42f824aaf85 --- collects/mred/private/wx/cocoa/canvas.rkt | 1203 ++++++++--------- collects/mred/private/wx/cocoa/dc.rkt | 5 +- collects/mred/private/wx/cocoa/frame.rkt | 6 +- collects/mred/private/wx/cocoa/window.rkt | 3 +- .../mred/private/wx/common/canvas-mixin.rkt | 58 + collects/mred/private/wx/common/delay.rkt | 20 +- collects/mred/private/wx/gtk/canvas.rkt | 842 ++++++------ collects/mred/private/wx/gtk/frame.rkt | 26 +- collects/mred/private/wx/gtk/panel.rkt | 5 + collects/mred/private/wx/gtk/window.rkt | 17 +- 10 files changed, 1108 insertions(+), 1077 deletions(-) create mode 100644 collects/mred/private/wx/common/canvas-mixin.rkt diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 1c0b2fba..8b7c86fc 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -16,6 +16,7 @@ "gc.rkt" "image.rkt" "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -164,650 +165,620 @@ (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) (define canvas% - (class window% - (init parent - x y w h - style - [ignored-name #f] - [gl-config #f]) + (canvas-mixin + (class window% + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) - (inherit get-cocoa get-cocoa-window - get-eventspace - make-graphics-context - is-shown-to-root? - is-shown-to-before-root? - move get-x get-y - on-size - register-as-child - get-size get-position - set-focus - client-to-screen) + (inherit get-cocoa get-cocoa-window + get-eventspace + make-graphics-context + is-shown-to-root? + is-shown-to-before-root? + move get-x get-y + on-size + register-as-child + get-size get-position + set-focus + client-to-screen) - (define vscroll-ok? (and (memq 'vscroll style) #t)) - (define vscroll? vscroll-ok?) - (define hscroll-ok? (and (memq 'hscroll style) #t)) - (define hscroll? hscroll-ok?) + (define vscroll-ok? (and (memq 'vscroll style) #t)) + (define vscroll? vscroll-ok?) + (define hscroll-ok? (and (memq 'hscroll style) #t)) + (define hscroll? hscroll-ok?) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) - (define wants-focus? (not (memq 'no-focus style))) - (define is-combo? (memq 'combo style)) - (define has-control-border? (and (not is-combo?) - (memq 'control-border style))) + (define wants-focus? (not (memq 'no-focus style))) + (define is-combo? (memq 'combo style)) + (define has-control-border? (and (not is-combo?) + (memq 'control-border style))) - (define-values (x-margin y-margin x-sb-margin y-sb-margin) - (cond - [has-control-border? (values 3 3 3 3)] - [(memq 'border style) (values 1 1 0 0)] - [else (values 0 0 0 0)])) + (define-values (x-margin y-margin x-sb-margin y-sb-margin) + (cond + [has-control-border? (values 3 3 3 3)] + [(memq 'border style) (values 1 1 0 0)] + [else (values 0 0 0 0)])) - (define canvas-style style) + (define canvas-style style) - (define/override (focus-is-on on?) - (when has-control-border? - (tellv cocoa setFocusState: #:type _BOOL on?) - (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) - (super focus-is-on on?)) + (define/override (focus-is-on on?) + (when has-control-border? + (tellv cocoa setFocusState: #:type _BOOL on?) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) + (super focus-is-on on?)) - ;; Avoid multiple queued paints, and also allow cancel - ;; of queued paint: - (define paint-queued #f) ; #f or (box #t) + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay (get-cocoa-window))) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) - (define/public (queue-paint) - ;; can be called from any thread, including the event-pump thread - (unless paint-queued - (let ([b (box #t)]) - (set! paint-queued b) - (let ([req (request-flush-delay (get-cocoa-window))]) - (queue-window-refresh-event - this - (lambda () (do-on-paint req b))))))) - - (define/private (do-on-paint req b) - ;; only called in the handler thread - (when (or (not b) (unbox b)) - (let ([pq paint-queued]) - (when pq (set-box! pq #f))) - (set! paint-queued #f) - (when (or (not b) (is-shown-to-root?)) - (send dc suspend-flush) - (send dc ensure-ready) - (send dc erase) ; start with a clean slate - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (send dc resume-flush) - (queue-backing-flush))) - (when req - (cancel-flush-delay req))) - - (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) - (if is-combo? 2 0) (if is-combo? 2 0)) - (begin - (queue-paint) - #f))) - - (define/override (paint-children) - (when (or paint-queued - (not (send dc can-backing-flush?))) - (do-on-paint #f #f))) - - (define/public (begin-refresh-sequence) - (send dc suspend-flush)) - (define/public (end-refresh-sequence) - (send dc resume-flush)) - - (define/public (get-flush-window) - (get-cocoa-window)) - - (define/override (refresh) - ;; can be called from any thread, including the event-pump thread - (queue-paint)) - - (define/public (queue-backing-flush) - ;; called atomically (not expecting exceptions) - (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) - - (define/override (get-cocoa-content) content-cocoa) - - (super-new - [parent parent] - [cocoa - (as-objc-allocation - (tell (tell (cond - [is-combo? NSView] - [has-control-border? FocusView] - [(memq 'border style) (if (memq 'vscroll style) - CornerlessFrameView - FrameView)] - [else NSView]) - alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) - (make-NSSize (max w (* 2 x-margin)) - (max h (* 2 y-margin))))))] - [no-show? (memq 'deleted style)]) - - (define cocoa (get-cocoa)) - - (define content-cocoa - (let ([r (make-NSRect (make-NSPoint 0 0) - (make-NSSize (max 0 (- w (* 2 x-margin))) - (max 0 (- h (* 2 y-margin)))))]) - (as-objc-allocation - (tell (tell (if is-combo? MyComboBox MyView) alloc) - initWithFrame: #:type _NSRect r)))) - (tell #:type _void cocoa addSubview: content-cocoa) - (set-ivar! content-cocoa wxb (->wxb this)) - - (when is-combo? - (tellv content-cocoa setEditable: #:type _BOOL #f) - (tellv content-cocoa setDelegate: content-cocoa) - (install-control-font content-cocoa #f)) - - (define dc (make-object dc% this)) - - (send dc start-backing-retained) - - (queue-paint) - - (define/public (get-dc) dc) - - (define/public (make-compatible-bitmap w h) - (make-object quartz-bitmap% w h)) - - (define/override (fix-dc [refresh? #t]) - (when (dc . is-a? . dc%) - (send dc reset-backing-retained) - (send dc set-auto-scroll - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0))) - (when refresh? (refresh))) - - (define/override (get-client-size xb yb) - (super get-client-size xb yb) - (when is-combo? - (set-box! yb (max 0 (- (unbox yb) 5))))) - - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - - (define/public (on-paint) (void)) - - (define/override (set-size x y w h) - (do-set-size x y w h)) - - (define tr 0) - - (define/override (show on?) - ;; FIXME: what if we're in the middle of an on-paint? - (super show on?) - (fix-dc)) - - (define/override (hide-children) - (super hide-children) - (suspend-all-reg-blits)) - - (define/override (show-children) - (super show-children) - (resume-all-reg-blits)) - - (define/private (do-set-size x y w h) - (when (pair? blits) - (atomically (suspend-all-reg-blits))) - (super set-size x y w h) - (when tr - (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) - (set! tr #f)) - (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) - (- h (if hscroll? scroll-width 0) y-margin y-margin))] - [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) - (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) - (set! tr (tell #:type _NSInteger - content-cocoa - addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) - owner: content-cocoa - userData: #f - assumeInside: #:type _BOOL #f))) - (when v-scroller - (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect - (make-NSRect - (make-NSPoint (- w scroll-width x-sb-margin) - (+ (if hscroll? - scroll-width - 0) - y-sb-margin)) - (make-NSSize scroll-width - (max 0 (- h (if hscroll? scroll-width 0) - x-sb-margin x-sb-margin)))))) - (when h-scroller - (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect - (make-NSRect - (make-NSPoint x-sb-margin y-sb-margin) - (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) - x-sb-margin x-sb-margin)) - scroll-width)))) - (when (and (pair? blits) - (is-shown-to-root?)) - (atomically (resume-all-reg-blits))) - (fix-dc) - (when auto-scroll? - (reset-auto-scroll 0 0)) - (on-size 0 0)) - - (define/public (show-scrollbars h? v?) - (let ([h? (and h? hscroll-ok?)] - [v? (and v? vscroll-ok?)]) - (unless (and (eq? h? hscroll?) - (eq? v? vscroll?)) - (cond - [(and h? (not hscroll?)) - (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] - [(and hscroll? (not h?)) - (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) - (set! hscroll? h?) - (cond - [(and v? (not vscroll?)) - (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] - [(and vscroll? (not v?)) - (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) - (set! vscroll? v?) - (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) - (get-position x y) - (get-size w h) - (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) - - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) h-len)) - (set! virtual-height (and (positive? v-len) v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] - [else - (let ([a? auto-scroll?]) - (set! auto-scroll? #f) - (when a? (fix-dc))) ; disable scroll offsets - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) - (set! virtual-width #f) - (set! virtual-height #f)])) - - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw - 0)] - [v-page (if virtual-height - ch - 0)]) - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) - - (define/private (refresh-for-autoscroll) - (fix-dc) - (refresh)) - - (define (update which scroll- v) - (if (eq? which 'vertical) - (scroll- v-scroller v) - (scroll- h-scroller v))) - - (define/public (set-scroll-page which v) - (update which scroll-page v)) - (define/public (set-scroll-range which v) - (update which scroll-range v)) - (define/public (set-scroll-pos which v) - (update which scroll-pos v)) - - (define/public (get-scroll-page which) - (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) - (define/public (get-scroll-range which) - (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) - (define/public (get-scroll-pos which) - (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) - - (define v-scroller - (and vscroll-ok? - (make-scroller - (as-objc-allocation - (tell (tell NSScroller alloc) initWithFrame: - #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-sb-margin) - (+ (if hscroll? - scroll-width - 0) - y-sb-margin)) - (make-NSSize scroll-width - (max (- h (if hscroll? scroll-width 0) - y-sb-margin y-sb-margin) - (+ scroll-width 10)))))) - 1 - 1))) - (define h-scroller - (and hscroll-ok? - (make-scroller - (as-objc-allocation - (tell (tell NSScroller alloc) initWithFrame: - #:type _NSRect (make-NSRect - (make-NSPoint x-sb-margin y-sb-margin) - (make-NSSize (max (- w (if vscroll? scroll-width 0) - x-sb-margin x-sb-margin) - (+ scroll-width 10)) - scroll-width)))) - 1 - 1))) - - (when v-scroller - (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) - (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) - (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) - (when h-scroller - (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) - (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) - (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) - - (define scroll-pos - (case-lambda - [(scroller val) - (when scroller - (tellv (scroller-cocoa scroller) setFloatValue: - #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) - 0.0)))] - [(scroller) - (if scroller - (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) - (scroller-range scroller)))) - 0)])) - - (define scroll-range - (case-lambda - [(scroller val) - (when scroller - (let ([pos (scroll-pos scroller)] - [page (scroll-page scroller)]) - (set-scroller-range! scroller val) - (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) - (scroll-pos scroller pos) - (scroll-page scroller page)))] - [(scroller) - (if scroller - (scroller-range scroller) - 1)])) - - (define scroll-page - (case-lambda - [(scroller val) - (when scroller - (set-scroller-page! scroller val) - (tellv (scroller-cocoa scroller) setKnobProportion: - #:type _CGFloat (max (min 1.0 (/ val - (+ val (exact->inexact (scroller-range scroller))))) - 0.0)))] - [(scroller) - (if scroller - (scroller-page scroller) - 1)])) - - (define/public (append-combo-item str) - (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) - #t) - (define/public (on-combo-select i) (void)) - - (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) (if (memq 'transparent canvas-style) - #f - bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) - (define/public (get-canvas-background-for-clearing) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) - bg-col)) - - (define/public (reject-partial-update r) - ;; Called in the event-pump thread. - ;; A transparent canvas cannot handle a partial update. - (and (or - ;; Multiple clipping rects? - (let ([i (malloc _NSInteger)] - [r (malloc 'atomic _pointer)]) - (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r - count: #:type _pointer i) - ((ptr-ref i _NSInteger) . > . 1)) - ;; Single clipping not whole area? - (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] - [s2 (NSRect-size r)]) - (or ((NSSize-width s2) . < . (NSSize-width s1)) - ((NSSize-height s2) . < . (NSSize-height s1))))) + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0)) (begin - (queue-window-event this (lambda () (refresh))) - #t))) + (queue-paint) + #f))) - (define/public (do-scroll direction scroller) - ;; Called from the Cocoa handler thread - (let ([part (tell #:type _int scroller hitPart)]) - (queue-window-event - this - (lambda () - (let ([kind - (cond - [(= part NSScrollerDecrementPage) - (set-scroll-pos direction (- (get-scroll-pos direction) - (get-scroll-page direction))) - 'page-up] - [(= part NSScrollerIncrementPage) - (set-scroll-pos direction (+ (get-scroll-pos direction) - (get-scroll-page direction))) - 'page-down] - [(= part NSScrollerDecrementLine) - (set-scroll-pos direction (- (get-scroll-pos direction) 1)) - 'line-up] - [(= part NSScrollerIncrementLine) - (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) - 'line-down] - [(= part NSScrollerKnob) - 'thumb] - [else #f])]) - (when kind - (if auto-scroll? - (refresh-for-autoscroll) - (on-scroll (new scroll-event% - [event-type kind] - [direction direction] - [position (get-scroll-pos direction)])))))))) - (constrained-reply (get-eventspace) - (lambda () - (let loop () (pre-event-sync #t) (when (yield) (loop)))) - (void))) - (define/public (on-scroll e) (void)) - - (define/override (definitely-wants-event? e) - ;; Called in Cocoa event-handling mode - (when (and wants-focus? - (e . is-a? . mouse-event%) - (send e button-down? 'left)) - (set-focus)) - (or (not is-combo?) - (e . is-a? . key-event%) - (not (send e button-down? 'left)) - (not (on-menu-click? e)))) + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) - (define/override (gets-focus?) - wants-focus?) - (define/override (can-be-responder?) - wants-focus?) + (define/public (get-flush-window) + (get-cocoa-window)) - (define/private (on-menu-click? e) - ;; Called in Cocoa event-handling mode - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - ((send e get-x) . > . (- (unbox xb) 22)))) + (define/override (refresh) + ;; can be called from any thread, including the event-pump thread + (queue-paint)) - (define/public (starting-combo) - (set! in-menu-click? #t) - (tellv content-cocoa setStringValue: #:type _NSString current-text)) - - (define/public (ending-combo) - (set! in-menu-click? #f) - (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) - (when (pos . > . -1) - (queue-window-event this (lambda () (on-combo-select pos))))) - (refresh)) + (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) + (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) - (define current-text "") - (define/public (set-combo-text t) - (set! current-text t)) + (define/override (get-cocoa-content) content-cocoa) - (define in-menu-click? #f) + (super-new + [parent parent] + [cocoa + (as-objc-allocation + (tell (tell (cond + [is-combo? NSView] + [has-control-border? FocusView] + [(memq 'border style) (if (memq 'vscroll style) + CornerlessFrameView + FrameView)] + [else NSView]) + alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize (max w (* 2 x-margin)) + (max h (* 2 y-margin))))))] + [no-show? (memq 'deleted style)]) - (define/public (during-menu-click?) - ;; Called in Cocoa event-handling mode - in-menu-click?) + (define cocoa (get-cocoa)) - (def/public-unimplemented set-background-to-gray) + (define content-cocoa + (let ([r (make-NSRect (make-NSPoint 0 0) + (make-NSSize (max 0 (- w (* 2 x-margin))) + (max 0 (- h (* 2 y-margin)))))]) + (as-objc-allocation + (tell (tell (if is-combo? MyComboBox MyView) alloc) + initWithFrame: #:type _NSRect r)))) + (tell #:type _void cocoa addSubview: content-cocoa) + (set-ivar! content-cocoa wxb (->wxb this)) - (define/public (scroll x y) - (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) - (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) - (when auto-scroll? (refresh-for-autoscroll))) + (when is-combo? + (tellv content-cocoa setEditable: #:type _BOOL #f) + (tellv content-cocoa setDelegate: content-cocoa) + (install-control-font content-cocoa #f)) - (def/public-unimplemented warp-pointer) + (define dc (make-object dc% this)) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (scroll-pos h-scroller) - 0)) - (set-box! yb (if virtual-height - (scroll-pos v-scroller) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (send dc start-backing-retained) - (define/public (set-resize-corner on?) - (void)) + (queue-paint) + + (define/public (get-dc) dc) - (define/public (get-backing-size xb yb) - (get-client-size xb yb) - (when is-combo? - (set-box! xb (- (unbox xb) 22)))) + (define/public (make-compatible-bitmap w h) + (make-object quartz-bitmap% w h)) - (define/override (get-cursor-width-delta) - (if is-combo? 22 0)) + (define/override (fix-dc [refresh? #t]) + (when (dc . is-a? . dc%) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0))) + (when refresh? (refresh))) - (define/public (is-flipped?) - (tell #:type _BOOL (get-cocoa-content) isFlipped)) + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (when is-combo? + (set-box! yb (max 0 (- (unbox yb) 5))))) - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) - (define blits null) - (define reg-blits null) + (define/public (on-paint) (void)) - (define/private (suspend-all-reg-blits) - (let ([cocoa-win (get-cocoa-window)]) - (for ([r (in-list reg-blits)]) - (tellv cocoa-win removeChildWindow: (car r)) - (release (car r)) - (scheme_remove_gc_callback (cdr r)))) - (set! reg-blits null)) + (define/override (set-size x y w h) + (do-set-size x y w h)) - (define/public (resume-all-reg-blits) - (unless (pair? reg-blits) - (when (pair? blits) - (set! reg-blits - (for/list ([b (in-list blits)]) - (let-values ([(x y w h img) (apply values b)]) - (register-one-blit x y w h img))))))) + (define tr 0) - (define/private (register-one-blit x y w h img) - (let ([xb (box x)] - [yb (box y)]) - (client-to-screen xb yb #f) - (let* ([cocoa-win (get-cocoa-window)]) - (atomically - (let ([win (as-objc-allocation - (tell (tell NSWindow alloc) - initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) - (- (unbox yb) - h)) - (make-NSSize w h)) - styleMask: #:type _int NSBorderlessWindowMask - backing: #:type _int NSBackingStoreBuffered - defer: #:type _BOOL NO))] - [iv (tell (tell NSImageView alloc) init)]) - (tellv iv setImage: img) - (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) - (make-NSSize w h))) - (tellv (tell win contentView) addSubview: iv) - (tellv win setAlphaValue: #:type _CGFloat 0.0) - (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) - (tellv iv release) - (let ([r (scheme_add_gc_callback - (make-gc-action-desc win (selector setAlphaValue:) 1.0) - (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) - (cons win r))))))) - - (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([on (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm)))]) - (let ([img (bitmap->image on)]) - (atomically - (set! blits (cons (list x y w h img) blits)) - (when (is-shown-to-root?) - (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + (define/override (show on?) + ;; FIXME: what if we're in the middle of an on-paint? + (super show on?) + (fix-dc)) - (define/public (unregister-collecting-blits) - (atomically - (suspend-all-reg-blits) - (set! blits null))))) + (define/override (hide-children) + (super hide-children) + (suspend-all-reg-blits)) + + (define/override (show-children) + (super show-children) + (resume-all-reg-blits)) + + (define/private (do-set-size x y w h) + (when (pair? blits) + (atomically (suspend-all-reg-blits))) + (super set-size x y w h) + (when tr + (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) + (set! tr #f)) + (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) + (- h (if hscroll? scroll-width 0) y-margin y-margin))] + [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) + (set! tr (tell #:type _NSInteger + content-cocoa + addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) + owner: content-cocoa + userData: #f + assumeInside: #:type _BOOL #f))) + (when v-scroller + (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max 0 (- h (if hscroll? scroll-width 0) + x-sb-margin x-sb-margin)))))) + (when h-scroller + (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin)) + scroll-width)))) + (when (and (pair? blits) + (is-shown-to-root?)) + (atomically (resume-all-reg-blits))) + (fix-dc) + (when auto-scroll? + (reset-auto-scroll 0 0)) + (on-size 0 0)) + + (define/public (show-scrollbars h? v?) + (let ([h? (and h? hscroll-ok?)] + [v? (and v? vscroll-ok?)]) + (unless (and (eq? h? hscroll?) + (eq? v? vscroll?)) + (cond + [(and h? (not hscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] + [(and hscroll? (not h?)) + (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) + (set! hscroll? h?) + (cond + [(and v? (not vscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] + [(and vscroll? (not v?)) + (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) + (set! vscroll? v?) + (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) + (get-position x y) + (get-size w h) + (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (when a? (fix-dc))) ; disable scroll offsets + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) + (set! virtual-width #f) + (set! virtual-height #f)])) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) + + (define/private (refresh-for-autoscroll) + (fix-dc) + (refresh)) + + (define (update which scroll- v) + (if (eq? which 'vertical) + (scroll- v-scroller v) + (scroll- h-scroller v))) + + (define/public (set-scroll-page which v) + (update which scroll-page v)) + (define/public (set-scroll-range which v) + (update which scroll-range v)) + (define/public (set-scroll-pos which v) + (update which scroll-pos v)) + + (define/public (get-scroll-page which) + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-range which) + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-pos which) + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) + + (define v-scroller + (and vscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max (- h (if hscroll? scroll-width 0) + y-sb-margin y-sb-margin) + (+ scroll-width 10)))))) + 1 + 1))) + (define h-scroller + (and hscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin) + (+ scroll-width 10)) + scroll-width)))) + 1 + 1))) + + (when v-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) + (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) + (when h-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) + (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) + + (define scroll-pos + (case-lambda + [(scroller val) + (when scroller + (tellv (scroller-cocoa scroller) setFloatValue: + #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) + 0.0)))] + [(scroller) + (if scroller + (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) + (scroller-range scroller)))) + 0)])) + + (define scroll-range + (case-lambda + [(scroller val) + (when scroller + (let ([pos (scroll-pos scroller)] + [page (scroll-page scroller)]) + (set-scroller-range! scroller val) + (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) + (scroll-pos scroller pos) + (scroll-page scroller page)))] + [(scroller) + (if scroller + (scroller-range scroller) + 1)])) + + (define scroll-page + (case-lambda + [(scroller val) + (when scroller + (set-scroller-page! scroller val) + (tellv (scroller-cocoa scroller) setKnobProportion: + #:type _CGFloat (max (min 1.0 (/ val + (+ val (exact->inexact (scroller-range scroller))))) + 0.0)))] + [(scroller) + (if scroller + (scroller-page scroller) + 1)])) + + (define/public (append-combo-item str) + (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) + #t) + (define/public (on-combo-select i) (void)) + + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if (memq 'transparent canvas-style) + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col)) + + (define/public (reject-partial-update r) + ;; Called in the event-pump thread. + ;; A transparent canvas cannot handle a partial update. + (and (or + ;; Multiple clipping rects? + (let ([i (malloc _NSInteger)] + [r (malloc 'atomic _pointer)]) + (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r + count: #:type _pointer i) + ((ptr-ref i _NSInteger) . > . 1)) + ;; Single clipping not whole area? + (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] + [s2 (NSRect-size r)]) + (or ((NSSize-width s2) . < . (NSSize-width s1)) + ((NSSize-height s2) . < . (NSSize-height s1))))) + (begin + (queue-window-event this (lambda () (refresh))) + #t))) + + (define/public (do-scroll direction scroller) + ;; Called from the Cocoa handler thread + (let ([part (tell #:type _int scroller hitPart)]) + (queue-window-event + this + (lambda () + (let ([kind + (cond + [(= part NSScrollerDecrementPage) + (set-scroll-pos direction (- (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-up] + [(= part NSScrollerIncrementPage) + (set-scroll-pos direction (+ (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-down] + [(= part NSScrollerDecrementLine) + (set-scroll-pos direction (- (get-scroll-pos direction) 1)) + 'line-up] + [(= part NSScrollerIncrementLine) + (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) + 'line-down] + [(= part NSScrollerKnob) + 'thumb] + [else #f])]) + (when kind + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)])))))))) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void))) + (define/public (on-scroll e) (void)) + + (define/override (definitely-wants-event? e) + ;; Called in Cocoa event-handling mode + (when (and wants-focus? + (e . is-a? . mouse-event%) + (send e button-down? 'left)) + (set-focus)) + (or (not is-combo?) + (e . is-a? . key-event%) + (not (send e button-down? 'left)) + (not (on-menu-click? e)))) + + (define/override (gets-focus?) + wants-focus?) + (define/override (can-be-responder?) + wants-focus?) + + (define/private (on-menu-click? e) + ;; Called in Cocoa event-handling mode + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + ((send e get-x) . > . (- (unbox xb) 22)))) + + (define/public (starting-combo) + (set! in-menu-click? #t) + (tellv content-cocoa setStringValue: #:type _NSString current-text)) + + (define/public (ending-combo) + (set! in-menu-click? #f) + (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) + (when (pos . > . -1) + (queue-window-event this (lambda () (on-combo-select pos))))) + (refresh)) + + (define current-text "") + (define/public (set-combo-text t) + (set! current-text t)) + + (define in-menu-click? #f) + + (define/public (during-menu-click?) + ;; Called in Cocoa event-handling mode + in-menu-click?) + + (def/public-unimplemented set-background-to-gray) + + (define/public (scroll x y) + (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) + (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) + (when auto-scroll? (refresh-for-autoscroll))) + + (def/public-unimplemented warp-pointer) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (scroll-pos h-scroller) + 0)) + (set-box! yb (if virtual-height + (scroll-pos v-scroller) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + + (define/public (set-resize-corner on?) + (void)) + + (define/public (get-backing-size xb yb) + (get-client-size xb yb) + (when is-combo? + (set-box! xb (- (unbox xb) 22)))) + + (define/override (get-cursor-width-delta) + (if is-combo? 22 0)) + + (define/public (is-flipped?) + (tell #:type _BOOL (get-cocoa-content) isFlipped)) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))) + + (define blits null) + (define reg-blits null) + + (define/private (suspend-all-reg-blits) + (let ([cocoa-win (get-cocoa-window)]) + (for ([r (in-list reg-blits)]) + (tellv cocoa-win removeChildWindow: (car r)) + (release (car r)) + (scheme_remove_gc_callback (cdr r)))) + (set! reg-blits null)) + + (define/public (resume-all-reg-blits) + (unless (pair? reg-blits) + (when (pair? blits) + (set! reg-blits + (for/list ([b (in-list blits)]) + (let-values ([(x y w h img) (apply values b)]) + (register-one-blit x y w h img))))))) + + (define/private (register-one-blit x y w h img) + (let ([xb (box x)] + [yb (box y)]) + (client-to-screen xb yb #f) + (let* ([cocoa-win (get-cocoa-window)]) + (atomically + (let ([win (as-objc-allocation + (tell (tell NSWindow alloc) + initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) + (- (unbox yb) + h)) + (make-NSSize w h)) + styleMask: #:type _int NSBorderlessWindowMask + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))] + [iv (tell (tell NSImageView alloc) init)]) + (tellv iv setImage: img) + (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))) + (tellv (tell win contentView) addSubview: iv) + (tellv win setAlphaValue: #:type _CGFloat 0.0) + (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) + (tellv iv release) + (let ([r (scheme_add_gc_callback + (make-gc-action-desc win (selector setAlphaValue:) 1.0) + (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) + (cons win r))))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))]) + (let ([img (bitmap->image on)]) + (atomically + (set! blits (cons (list x y w h img) blits)) + (when (is-shown-to-root?) + (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (suspend-all-reg-blits) + (set! blits null)))))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 7621a639..278d2cbb 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -35,8 +35,9 @@ (define/override (release-bitmap-storage) (atomically - (cairo_surface_destroy s) - (set! s #f))))) + (when s + (cairo_surface_destroy s) + (set! s #f)))))) (define dc% (class backing-dc% diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 460251d9..78acf5f6 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -475,8 +475,10 @@ (and on? #t)) (tellv cocoa zoom: cocoa))) - (def/public-unimplemented iconized?) - (def/public-unimplemented iconize) + (define/public (iconized?) + (tell #:type _BOOL cocoa isMiniaturized)) + (define/public (iconize on?) + (tellv cocoa miniaturize: cocoa)) (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index d89757db..530d263a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -663,7 +663,8 @@ (do-request-flush-delay cocoa-win (lambda (cocoa-win) - (tellv cocoa-win disableFlushWindow)) + (tellv cocoa-win disableFlushWindow) + #t) (lambda (cocoa-win) (tellv cocoa-win enableFlushWindow)))) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt new file mode 100644 index 00000000..2316c727 --- /dev/null +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require racket/class + "backing-dc.rkt") + +(provide canvas-mixin) + +(define (canvas-mixin %) + (class % + (super-new) + (inherit request-canvas-flush-delay + cancel-canvas-flush-delay + queue-canvas-refresh-event + is-shown-to-root? + on-paint + queue-backing-flush + get-dc + get-canvas-background) + + ;; Avoid multiple queued paints, and also allow cancel + ;; of queued paint: + (define paint-queued #f) ; #f or (box #t) + + (define/override (queue-paint) + ;; can be called from any thread, including the event-pump thread + (unless paint-queued + (let ([b (box #t)]) + (set! paint-queued b) + (let ([req (request-canvas-flush-delay)]) + (queue-canvas-refresh-event + (lambda () (do-on-paint req b))))))) + + (define/private (do-on-paint req b) + ;; only called in the handler thread + (when (or (not b) (unbox b)) + (let ([pq paint-queued]) + (when pq (set-box! pq #f))) + (set! paint-queued #f) + (when (or (not b) (is-shown-to-root?)) + (let ([dc (get-dc)]) + (send dc suspend-flush) + (send dc ensure-ready) + (send dc erase) ; start with a clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (send dc resume-flush) + (queue-backing-flush)))) + (when req + (cancel-canvas-flush-delay req))) + + (define/override (paint-children) + (when (or paint-queued + (not (send (get-dc) can-backing-flush?))) + (do-on-paint #f #f))))) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index ef2aba0a..0a348b08 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -8,15 +8,17 @@ (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) - (disable win) - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) - req))) + (and + (disable win) + (begin + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win)))) + req))))) (define (do-cancel-flush-delay req enable) (atomically diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 96a13b69..a3ec1227 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -6,6 +6,7 @@ racket/draw/color racket/draw/local "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" "../../syntax.rkt" "../../lock.rkt" "../common/event.rkt" @@ -176,461 +177,434 @@ #t) (define canvas% - (class (client-size-mixin window%) - (init parent - x y w h - style - [ignored-name #f] - [gl-config #f]) + (canvas-mixin + (class (client-size-mixin window%) + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) - (inherit get-gtk set-size get-size get-client-size - on-size get-top-win - set-auto-size - adjust-client-delta infer-client-delta) + (inherit get-gtk set-size get-size get-client-size + on-size get-top-win + set-auto-size + adjust-client-delta infer-client-delta) - (define is-combo? (memq 'combo style)) - (define has-border? (or (memq 'border style) - (memq 'control-border style))) + (define is-combo? (memq 'combo style)) + (define has-border? (or (memq 'border style) + (memq 'control-border style))) - (define margin (if has-border? 1 0)) + (define margin (if has-border? 1 0)) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) - (define-values (client-gtk gtk - hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box - combo-button-gtk - scroll-width) - (atomically ;; need to connect all children to gtk to avoid leaks - (cond - [(or (memq 'hscroll style) - (memq 'vscroll style)) - (let* ([client-gtk (gtk_drawing_area_new)] - [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] - [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) - (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] - [v (gtk_vbox_new #f 0)] - [v2 (gtk_vbox_new #f 0)] - [h2 (gtk_vbox_new #f 0)] - [hscroll (gtk_hscrollbar_new hadj)] - [vscroll (gtk_vscrollbar_new vadj)] - [resize-box (gtk_drawing_area_new)]) - ;; |------------------------------------| - ;; | h |-----------------| |-----------|| - ;; | | v | | v2 || - ;; | | | | [vscroll] || - ;; | | [h2 [hscroll]] | | [resize] || - ;; | |-----------------| |-----------|| - ;; |------------------------------------| - (when has-border? - (gtk_container_set_border_width h margin)) - (gtk_box_pack_start h v #t #t 0) - (gtk_box_pack_start v client-gtk #t #t 0) - (gtk_box_pack_start h v2 #f #f 0) - (gtk_box_pack_start v2 vscroll #t #t 0) - (gtk_box_pack_start v h2 #f #f 0) - (gtk_box_pack_start h2 hscroll #t #t 0) - (gtk_box_pack_start v2 resize-box #f #f 0) - (when (memq 'hscroll style) - (gtk_widget_show hscroll)) - (gtk_widget_show vscroll) - (gtk_widget_show h) - (gtk_widget_show v) - (when (memq 'vscroll style) - (gtk_widget_show v2)) - (gtk_widget_show h2) - (when (memq 'hscroll style) - (gtk_widget_show resize-box)) - (gtk_widget_show client-gtk) - (let ([req (make-GtkRequisition 0 0)]) - (gtk_widget_size_request vscroll req) - (values client-gtk h hadj vadj - (and (memq 'hscroll style) h2) - (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box) - #f - (GtkRequisition-width req)))))] - [is-combo? - (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] - [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] - [has-border? - (let ([client-gtk (gtk_drawing_area_new)] - [h (as-gtk-allocation (gtk_hbox_new #f 0))]) - (gtk_box_pack_start h client-gtk #t #t 0) - (gtk_container_set_border_width h margin) - (connect-expose-border h) - (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f #f 0))] - [else - (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) - (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) - - (super-new [parent parent] - [gtk gtk] - [client-gtk client-gtk] - [no-show? (memq 'deleted style)] - [extra-gtks (if (eq? client-gtk gtk) - null - (if hscroll-adj - (list client-gtk hscroll-adj vscroll-adj) - (if combo-button-gtk - (list client-gtk combo-button-gtk) - (list client-gtk))))]) - - (set-size x y w h) - - (define dc (new dc% [canvas this])) - - (gtk_widget_realize gtk) - (gtk_widget_realize client-gtk) - - (when resize-box - (let ([r (make-GtkRequisition 0 0)]) - (gtk_widget_size_request hscroll-gtk r) - (gtk_widget_set_size_request resize-box - (GtkRequisition-height r) - (GtkRequisition-height r)))) - - (connect-expose client-gtk) - #;(gtk_widget_set_double_buffered client-gtk #f) - (connect-key-and-mouse client-gtk) - (connect-focus client-gtk) - (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK - GDK_KEY_RELEASE_MASK - GDK_BUTTON_PRESS_MASK - GDK_BUTTON_RELEASE_MASK - GDK_POINTER_MOTION_MASK - GDK_FOCUS_CHANGE_MASK - GDK_ENTER_NOTIFY_MASK - GDK_LEAVE_NOTIFY_MASK)) - (unless (memq 'no-focus style) - (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) - GTK_CAN_FOCUS))) - (when combo-button-gtk - (connect-combo-key-and-mouse combo-button-gtk)) - - (when hscroll-adj (connect-value-changed-h hscroll-adj)) - (when vscroll-adj (connect-value-changed-v vscroll-adj)) - - (set-auto-size) - (adjust-client-delta (+ (* 2 margin) - (if (memq 'vscroll style) - scroll-width - 0)) - (+ (* 2 margin) - (if (memq 'hscroll style) - scroll-width - 0))) - - (define/override (direct-update?) #f) - - (define/public (get-dc) dc) - - (define/public (make-compatible-bitmap w h) - (send dc make-backing-bitmap w h)) - - (define/override (get-client-gtk) client-gtk) - (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) - - (define/override (get-client-delta) - (values margin margin)) - - ;; Avoid multiple queued paints: - (define paint-queued? #f) - ;; To handle paint requests that happen while on-paint - ;; is being called already. kProbably doesn't happen, - ;; because expose callabcks should be in the right - ;; eventspace. - (define now-drawing? #f) - (define refresh-after-drawing? #f) - - (define/public (queue-paint) - ;; can be called from any thread, including the event-pump thread - (unless paint-queued? - (set! paint-queued? #t) - (queue-window-refresh-event - this - (lambda () - (set! paint-queued? #f) - (set! now-drawing? #t) - (send dc suspend-flush) - (send dc ensure-ready) - (send dc erase) ; clean slate - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (send dc resume-flush) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh)))))) - - (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (if is-combo? - (get-subwindow client-gtk) - (widget-window client-gtk))) - (begin - (queue-paint) - #f))) - - (define/public (on-paint) (void)) - - (define/public (get-flush-window) client-gtk) - - (define/public (begin-refresh-sequence) - (send dc suspend-flush)) - (define/public (end-refresh-sequence) - (send dc resume-flush)) - - (define/override (refresh) - (queue-paint)) - - (define/public (queue-backing-flush) - ;; called atomically (not expecting exceptions) - (gtk_widget_queue_draw client-gtk)) - - (define/override (reset-child-dcs) - (when (dc . is-a? . dc%) - (reset-dc))) - - (send dc start-backing-retained) - - (define/private (reset-dc) - (send dc reset-backing-retained) - (refresh) - (send dc set-auto-scroll - (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0) - (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0))) - - (define/override (internal-on-client-size w h) - (reset-dc)) - (define/override (on-client-size w h) - (let ([xb (box 0)] - [yb (box 0)]) - (get-size xb yb) - (on-size (unbox xb) (unbox yb)))) - - (define/public (show-scrollbars h? v?) - (when hscroll-gtk - (if h? - (gtk_widget_show hscroll-gtk) - (gtk_widget_hide hscroll-gtk))) - (when vscroll-gtk - (if v? - (gtk_widget_show vscroll-gtk) - (gtk_widget_hide vscroll-gtk))) - (when (and hscroll-gtk vscroll-gtk) + (define-values (client-gtk gtk + hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box + combo-button-gtk + scroll-width) + (atomically ;; need to connect all children to gtk to avoid leaks (cond - [(and v? h?) - (gtk_widget_show resize-box)] - [(and v? (not h?)) - ;; remove corner - (gtk_widget_hide resize-box)])) - (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) - (+ (* 2 margin) (if h? scroll-width 0)))) - - (define/private (configure-adj adj scroll-gtk len page pos) - (when (and scroll-gtk adj) - (if (zero? len) - (gtk_adjustment_configure adj 0 0 1 1 1 1) - (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) - - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (let ([h-page (if (zero? h-len) 0 h-page)] - [v-page (if (zero? v-len) 0 v-page)]) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) - (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + ;; |------------------------------------| + ;; | h |-----------------| |-----------|| + ;; | | v | | v2 || + ;; | | | | [vscroll] || + ;; | | [h2 [hscroll]] | | [resize] || + ;; | |-----------------| |-----------|| + ;; |------------------------------------| + (when has-border? + (gtk_container_set_border_width h margin)) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (when (memq 'hscroll style) + (gtk_widget_show hscroll)) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (when (memq 'vscroll style) + (gtk_widget_show v2)) + (gtk_widget_show h2) + (when (memq 'hscroll style) + (gtk_widget_show resize-box)) + (gtk_widget_show client-gtk) + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request vscroll req) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f + (GtkRequisition-width req)))))] + [is-combo? + (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] + [orig-entry (gtk_bin_get_child gtk)]) + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (as-gtk-allocation (gtk_hbox_new #f 0))]) + (gtk_box_pack_start h client-gtk #t #t 0) + (gtk_container_set_border_width h margin) + (connect-expose-border h) + (gtk_widget_show client-gtk) + (values client-gtk h #f #f #f #f #f #f 0))] [else - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) + (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) + (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [no-show? (memq 'deleted style)] + [extra-gtks (if (eq? client-gtk gtk) + null + (if hscroll-adj + (list client-gtk hscroll-adj vscroll-adj) + (if combo-button-gtk + (list client-gtk combo-button-gtk) + (list client-gtk))))]) + + (set-size x y w h) + + (define dc (new dc% [canvas this])) + + (gtk_widget_realize gtk) + (gtk_widget_realize client-gtk) + + (when resize-box + (let ([r (make-GtkRequisition 0 0)]) + (gtk_widget_size_request hscroll-gtk r) + (gtk_widget_set_size_request resize-box + (GtkRequisition-height r) + (GtkRequisition-height r)))) + + (connect-expose client-gtk) + #;(gtk_widget_set_double_buffered client-gtk #f) + (connect-key-and-mouse client-gtk) + (connect-focus client-gtk) + (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_KEY_RELEASE_MASK + GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) + (unless (memq 'no-focus style) + (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) + GTK_CAN_FOCUS))) + (when combo-button-gtk + (connect-combo-key-and-mouse combo-button-gtk)) + + (when hscroll-adj (connect-value-changed-h hscroll-adj)) + (when vscroll-adj (connect-value-changed-v vscroll-adj)) + + (set-auto-size) + (adjust-client-delta (+ (* 2 margin) + (if (memq 'vscroll style) + scroll-width + 0)) + (+ (* 2 margin) + (if (memq 'hscroll style) + scroll-width + 0))) + + (define/override (direct-update?) #f) + + (define/public (get-dc) dc) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define/override (get-client-gtk) client-gtk) + (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) + + (define/override (get-client-delta) + (values margin margin)) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay client-gtk)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (widget-window client-gtk))) + (begin + (queue-paint) + #f))) + + (define/public (on-paint) (void)) + + (define/public (get-flush-window) client-gtk) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + (define/override (refresh) + (queue-paint)) + + (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) + (gtk_widget_queue_draw client-gtk)) + + (define/override (reset-child-dcs) + (when (dc . is-a? . dc%) + (reset-dc))) + + (send dc start-backing-retained) + + (define/private (reset-dc) + (send dc reset-backing-retained) + (refresh) + (send dc set-auto-scroll + (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0) + (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + + (define/override (internal-on-client-size w h) + (reset-dc)) + (define/override (on-client-size w h) + (let ([xb (box 0)] + [yb (box 0)]) + (get-size xb yb) + (on-size (unbox xb) (unbox yb)))) + + (define/public (show-scrollbars h? v?) + (when hscroll-gtk + (if h? + (gtk_widget_show hscroll-gtk) + (gtk_widget_hide hscroll-gtk))) + (when vscroll-gtk + (if v? + (gtk_widget_show vscroll-gtk) + (gtk_widget_hide vscroll-gtk))) + (when (and hscroll-gtk vscroll-gtk) + (cond + [(and v? h?) + (gtk_widget_show resize-box)] + [(and v? (not h?)) + ;; remove corner + (gtk_widget_hide resize-box)])) + (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) + (+ (* 2 margin) (if h? scroll-width 0)))) + + (define/private (configure-adj adj scroll-gtk len page pos) + (when (and scroll-gtk adj) + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (let ([h-page (if (zero? h-len) 0 h-page)] + [v-page (if (zero? v-len) 0 v-page)]) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) + (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) 0)] - [v-page (if virtual-height - ch - 0)]) - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) - (define/private (refresh-for-autoscroll) - (reset-dc) - (refresh)) + (define/private (refresh-for-autoscroll) + (reset-dc) + (refresh)) - (define/private (dispatch which proc [default (void)]) - (if (eq? which 'vertical) - (if vscroll-adj (proc vscroll-adj) default) - (if hscroll-adj (proc hscroll-adj) default))) + (define/private (dispatch which proc [default (void)]) + (if (eq? which 'vertical) + (if vscroll-adj (proc vscroll-adj) default) + (if hscroll-adj (proc hscroll-adj) default))) - (define/public (set-scroll-page which v) - (dispatch which (lambda (adj) - (let ([old (gtk_adjustment_get_page_size adj)]) - (unless (= old v) - (gtk_adjustment_set_page_size adj v) - (gtk_adjustment_set_page_increment adj v) - (gtk_adjustment_set_upper adj (+ (- v old) - (gtk_adjustment_get_upper adj)))))))) - (define/public (set-scroll-range which v) - (dispatch which (lambda (adj) - (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) - (define/public (set-scroll-pos which v) - (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) + (define/public (set-scroll-page which v) + (dispatch which (lambda (adj) + (let ([old (gtk_adjustment_get_page_size adj)]) + (unless (= old v) + (gtk_adjustment_set_page_size adj v) + (gtk_adjustment_set_page_increment adj v) + (gtk_adjustment_set_upper adj (+ (- v old) + (gtk_adjustment_get_upper adj)))))))) + (define/public (set-scroll-range which v) + (dispatch which (lambda (adj) + (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) + (define/public (set-scroll-pos which v) + (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) - (define/public (get-scroll-page which) - (->long (dispatch which gtk_adjustment_get_page_size 0))) - (define/public (get-scroll-range which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_upper adj) - (gtk_adjustment_get_page_size adj))) - 0))) - (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value 0))) - - (define clear-bg? - (and (not (memq 'transparent style)) - (not (memq 'no-autoclear style)))) - (define transparent? - (memq 'transparent style)) - (define gc #f) - (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) (if transparent? - #f - bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) - (define/public (get-canvas-background-for-clearing) - ;; called in event-dispatch mode - (if now-drawing? - (begin - (set! refresh-after-drawing? #t) - #f) - (if clear-bg? - (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] - [w (widget-window gtk)] - [gc (gdk_gc_new w)]) - (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 - (conv (color-red bg-col)) - (conv (color-green bg-col)) - (conv (color-blue bg-col)))) - gc) - #f))) + (define/public (get-scroll-page which) + (->long (dispatch which gtk_adjustment_get_page_size 0))) + (define/public (get-scroll-range which) + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0))) + (define/public (get-scroll-pos which) + (->long (dispatch which gtk_adjustment_get_value 0))) + + (define clear-bg? + (and (not (memq 'transparent style)) + (not (memq 'no-autoclear style)))) + (define transparent? + (memq 'transparent style)) + (define gc #f) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + ;; called in event-dispatch mode + (if clear-bg? + (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] + [w (widget-window gtk)] + [gc (gdk_gc_new w)]) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 + (conv (color-red bg-col)) + (conv (color-green bg-col)) + (conv (color-blue bg-col)))) + gc) + #f)) - (when is-combo? - (connect-changed client-gtk)) + (when is-combo? + (connect-changed client-gtk)) - (define/public (append-combo-item str) - (gtk_combo_box_append_text gtk str)) + (define/public (append-combo-item str) + (gtk_combo_box_append_text gtk str)) - (define/public (combo-maybe-clicked) - (let ([i (gtk_combo_box_get_active gtk)]) - (when (i . > . -1) - (gtk_combo_box_set_active gtk -1) - (queue-window-event this (lambda () (on-combo-select i)))))) - (define/public (on-combo-select i) (void)) + (define/public (combo-maybe-clicked) + (let ([i (gtk_combo_box_get_active gtk)]) + (when (i . > . -1) + (gtk_combo_box_set_active gtk -1) + (queue-window-event this (lambda () (on-combo-select i)))))) + (define/public (on-combo-select i) (void)) - (define/public (set-combo-text t) (void)) + (define/public (set-combo-text t) (void)) - (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented set-background-to-gray) - (define/public (do-scroll direction) - (if auto-scroll? - (refresh-for-autoscroll) - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction direction] - [position (get-scroll-pos direction)])))) - (define/public (on-scroll e) (void)) + (define/public (do-scroll direction) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)])))) + (define/public (on-scroll e) (void)) - (define/public (scroll x y) - (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) - (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) - (when auto-scroll? (refresh-for-autoscroll))) + (define/public (scroll x y) + (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) + (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) + (when auto-scroll? (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (def/public-unimplemented warp-pointer) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0)) - (set-box! yb (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0)) + (set-box! yb (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) - (define/public (set-resize-corner on?) (void)) - - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) + (define/public (set-resize-corner on?) (void)) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))) - (define reg-blits null) - - (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) - (let* ([cwin (widget-window client-gtk)]) - (atomically - (let ([win (create-gc-window cwin x y w h)]) - (let ([r (scheme_add_gc_callback - (make-gc-show-desc win on-pixbuf w h) - (make-gc-hide-desc win off-pixbuf w h))]) - (cons win r)))))) - - (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([fix-size (lambda (on on-x on-y) - (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm))))]) - (let ([on (fix-size on on-x on-y)] - [off (fix-size off off-x off-y)]) - (let ([on-pixbuf (bitmap->pixbuf on)] - [off-pixbuf (bitmap->pixbuf off)]) - (atomically - (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) - - (define/public (unregister-collecting-blits) - (atomically - (for ([r (in-list reg-blits)]) - (g_object_unref (car r)) - (scheme_remove_gc_callback (cdr r))) - (set! reg-blits null))))) + (define reg-blits null) + + (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) + (let* ([cwin (widget-window client-gtk)]) + (atomically + (let ([win (create-gc-window cwin x y w h)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc win on-pixbuf w h) + (make-gc-hide-desc win off-pixbuf w h))]) + (cons win r)))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([fix-size (lambda (on on-x on-y) + (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm))))]) + (let ([on (fix-size on on-x on-y)] + [off (fix-size off off-x off-y)]) + (let ([on-pixbuf (bitmap->pixbuf on)] + [off-pixbuf (bitmap->pixbuf off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (g_object_unref (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c872fcb9..2a0bc0ba 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -237,14 +237,24 @@ (gtk_window_resize gtk (max 1 w) (max 1 h))) (define/override (show on?) - (when (and on? - (eventspace-shutdown? (get-eventspace))) - (error (string->symbol - (format "show method in ~a" - (if (frame-relative-dialog-status this) - 'dialog% - 'frame%))) - "eventspace has been shutdown")) + (let ([es (get-eventspace)]) + (when (and on? + (eventspace-shutdown? es)) + (error (string->symbol + (format "show method in ~a" + (if (frame-relative-dialog-status this) + 'dialog% + 'frame%))) + "eventspace has been shutdown") + (when saved-child + (if (eq? (current-thread) (eventspace-handler-thread es)) + (send saved-child paint-children) + (let ([s (make-semaphore)]) + (queue-callback (lambda () + (when saved-child + (send saved-child paint-children)) + (semaphore-post s))) + (sync/timeout 1 s)))))) (super show on?)) (define saved-child #f) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 767db962..4947b465 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -32,6 +32,11 @@ (for ([child (in-list children)]) (send child reset-child-dcs)))) + (define/override (paint-children) + (when (pair? children) + (for ([child (in-list children)]) + (send child paint-children)))) + (define/override (set-size x y w h) (super set-size x y w h) (reset-child-dcs)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index ef295165..7a36b67b 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -568,6 +568,9 @@ (when parent (send parent register-child this on?))) + (define/public (paint-children) + (void)) + (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) @@ -625,12 +628,16 @@ (do-request-flush-delay gtk (lambda (gtk) - (gdk_window_freeze_updates (widget-window gtk))) + (let ([win (widget-window gtk)]) + (and win + (gdk_window_freeze_updates win) + #t))) (lambda (gtk) (gdk_window_thaw_updates (widget-window gtk))))) (define (cancel-flush-delay req) - (do-cancel-flush-delay - req - (lambda (gtk) - (gdk_window_thaw_updates (widget-window gtk))))) + (when req + (do-cancel-flush-delay + req + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk)))))) From 93b790f2281cbf9fa1bb757f7c0c08a3d4daec23 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Sep 2010 07:18:46 -0600 Subject: [PATCH 222/462] centralize default-font configuration original commit: 60d4eaf2279697012f4f07e720cedb0b2038b4a9 --- collects/mred/private/gdi.rkt | 71 +---------------------------------- 1 file changed, 2 insertions(+), 69 deletions(-) diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 659e38ef..01bcbf9c 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -224,78 +224,11 @@ [() (get-face-list 'all)] [(a) (sort (wx:get-face-list a) compare-face-names)])) - (define x-has-xft? 'unknown) - (define mswin-system #f) - (define mswin-default #f) - (define (look-for-font name) - (if (ormap (lambda (n) (string-ci=? name n)) (wx:get-face-list)) - name - "MS San Serif")) - (define (get-family-builtin-face family) (unless (memq family '(default decorative roman script swiss modern system symbol)) (raise-type-error 'get-family-builtin-face "family symbol" family)) - (case (system-type) - [(unix) - ;; Detect Xft by looking for a font with a space in front of its name: - (when (eq? x-has-xft? 'unknown) - (set! x-has-xft? (ormap (lambda (s) (regexp-match #rx"^ " s)) (wx:get-face-list)))) - (if x-has-xft? - (case family - [(system) " Sans"] - [(default) " Sans"] - [(roman) " Serif"] - [(decorative) " Nimbus Sans L"] - [(modern) " Monospace"] - [(swiss) " Nimbus Sans L"] - [(script) " URW Chancery L"] - [(symbol) " Standard Symbols L,Nimbus Sans L"]) - (case family - [(system) "-b&h-lucida"] - [(default) "-b&h-lucida"] - [(roman) "-adobe-times"] - [(decorative) "-adobe-helvetica"] - [(modern) "-adobe-courier"] - [(swiss) "-b&h-lucida"] - [(script) "-itc-zapfchancery"] - [(symbol) "-adobe-symbol"]))] - [(windows) - (case family - [(system) - (unless mswin-system - (set! mswin-system (look-for-font "Tahoma"))) - mswin-system] - [(default) - (unless mswin-default - (set! mswin-default (look-for-font "Microsoft Sans Serif"))) - mswin-default] - [(default) "MS Sans Serif"] - [(roman) "Times New Roman"] - [(decorative) "Arial"] - [(modern) "Courier New"] - [(swiss) "Arial"] - [(script) "Arial"] - [(symbol) "Symbol"])] - [(macos) - (case family - [(system) "systemfont"] - [(default) "applicationfont"] - [(roman) "Times"] - [(decorative) "Geneva"] - [(modern) "Monaco"] - [(swiss) "Helvetica"] - [(script) "Zaph Chancery"] - [(symbol) "Symbol"])] - [(macosx) - (case family - [(system) "systemfont"] - [(default) "applicationfont"] - [(roman) "Times"] - [(decorative) "Arial"] - [(modern) "Courier New"] - [(swiss) "Helvetica"] - [(script) "Apple Chancery"] - [(symbol) "Symbol"])])) + (let ([id (send wx:the-font-name-directory find-family-default-font-id family)]) + (send wx:the-font-name-directory get-screen-name id 'normal 'normal))) (define small-delta (case (system-type) [(windows) 0] From 26c1a8e5bfcc8ebf0cfaa5f1b37aaf65ede011c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 11:16:42 -0600 Subject: [PATCH 223/462] use right color space of cocoa highlight? original commit: 6f390ac65583bcee8355f44645f4eaf27df51612 --- collects/mred/private/wx/cocoa/procs.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index a4f6e049..483e1121 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -130,12 +130,12 @@ (import-class NSColor) -(define-cocoa NSCalibratedRGBColorSpace _id) +(define-cocoa NSDeviceRGBColorSpace _id) (define (get-highlight-background-color) (let ([hi (as-objc-allocation-with-retain (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSCalibratedRGBColorSpace))] + colorUsingColorSpaceName: NSDeviceRGBColorSpace))] [as-color (lambda (v) (inexact->exact (floor (* 255.0 v))))]) (begin0 From f8c7790afbebc390d724d12a7175d5f9b044278d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 20:57:20 -0600 Subject: [PATCH 224/462] cocoa on-drop-files original commit: 83a00c66ecc75be7a01a5b4ab8a9619e27985757 --- collects/mred/private/wx/cocoa/frame.rkt | 10 +++- collects/mred/private/wx/cocoa/panel.rkt | 9 ++- collects/mred/private/wx/cocoa/window.rkt | 72 +++++++++++++++++++++-- collects/mrlib/name-message.rkt | 4 +- 4 files changed, 83 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 78acf5f6..376fc7f5 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -113,7 +113,8 @@ (inherit get-cocoa get-parent get-eventspace pre-on-char pre-on-event - get-x get-y) + get-x get-y + on-new-child) (super-new [parent parent] [cocoa @@ -293,6 +294,10 @@ (when saved-child (send saved-child show-children))) + (define/override (children-accept-drag on?) + (when saved-child + (send saved-child child-accept-drag on?))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) @@ -314,7 +319,8 @@ (unless on? (error 'register-child-in-frame "did not expect #f")) (unless (or (not saved-child) (eq? child saved-child)) (error 'register-child-in-frame "expected only one child")) - (set! saved-child child)) + (set! saved-child child) + (on-new-child child #t)) (define/override (set-cursor c) (when saved-child diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 67ced261..aad8308a 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -20,7 +20,7 @@ (define (panel-mixin %) (class % - (inherit register-as-child) + (inherit register-as-child on-new-child) (define lbl-pos 'horizontal) (define children null) @@ -45,6 +45,10 @@ (define/override (paint-children) (for ([child (in-list children)]) (send child paint-children))) + + (define/override (children-accept-drag on?) + (for ([child (in-list children)]) + (send child child-accept-drag on?))) (define/override (set-size x y w h) (super set-size x y w h) @@ -59,7 +63,8 @@ (set! children (if on? (cons child children) - (remq child children)))))) + (remq child children))) + (on-new-child child on?)))) (define/override (show on?) (super show on?) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 530d263a..1ae62f73 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require ffi/objc - scheme/foreign +(require ffi/unsafe/objc + ffi/unsafe scheme/class "queue.rkt" "utils.rkt" @@ -16,8 +16,6 @@ "../common/delay.rkt" "../../syntax.rkt" "../common/freeze.rkt") -(unsafe!) -(objc-unsafe!) (provide window% @@ -77,6 +75,8 @@ (define current-insert-text (make-parameter #f)) +(define NSDragOperationCopy 1) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -172,7 +172,26 @@ [-a _NSInteger (conversationIdentifier) 0] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) - (make-NSSize 0 0))]) + (make-NSSize 0 0))] + + ;; Dragging: + [-a _int (draggingEntered: [_id info]) + NSDragOperationCopy] + [-a _BOOL (prepareForDragOperation: [_id info]) + #t] + [-a _BOOL (performDragOperation: [_id info]) + (let ([wx (->wx wxb)]) + (when wx + (with-autorelease + (let ([pb (tell info draggingPasteboard)]) + (let ([data (tell pb propertyListForType: NSFilenamesPboardType)]) + (when data + (for ([i (in-range (tell #:type _NSUInteger data count))]) + (let ([s (tell #:type _NSString data objectAtIndex: #:type _NSUInteger i)]) + (queue-window-event wx + (lambda () + (send wx do-on-drop-file s))))))))))) + #t]) (define-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -315,6 +334,8 @@ (lambda () (send wx dispatch-on-event m #t)) #t))))))))) +(define-cocoa NSFilenamesPboardType _id) + (define window% (class object% (init-field parent @@ -400,6 +421,16 @@ (define/public (register-child child on?) (void)) + (define/public (on-new-child child on?) + (if on? + (queue-window-event + child + (lambda () + (atomically + (with-autorelease + (send child child-accept-drag (or accept-drag? accept-parent-drag?)))))) + (send child child-accept-drag #f))) + (define/public (is-shown?) (and (tell cocoa superview) #t)) @@ -483,8 +514,38 @@ (define/public (move x y) (set-size x y (get-width) (get-height))) + (define accept-drag? #f) + (define accept-parent-drag? #f) + + (define/public (on-drop-file f) (void)) + (define/public (do-on-drop-file f) + (if accept-drag? + (on-drop-file (string->path f)) + (when parent + (send parent do-on-drop-file f)))) + (define/public (drag-accept-files on?) + (unless (eq? (and on? #t) accept-drag?) + (atomically + (with-autorelease + (set! accept-drag? (and on? #t)) + (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))))) + + (define/public (accept-drags-everywhere on?) + (if on? + (tellv (get-cocoa-content) registerForDraggedTypes: + (let ([a (tell NSArray arrayWithObjects: #:type (_list i _id) (list NSFilenamesPboardType) + count: #:type _NSUInteger 1)]) + a)) + (tellv (get-cocoa-content) unregisterDraggedTypes)) + (children-accept-drag on?)) + + (define/public (children-accept-drag on?) (void)) + (define/public (child-accept-drag on?) + (unless (eq? (and on? #t) accept-parent-drag?) + (set! accept-parent-drag? (and on? #t)) + (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))) (define/public (set-focus) (when (gets-focus?) @@ -579,7 +640,6 @@ (set! sticky-cursor? #f) (send (get-parent) end-no-cursor-rects)) - (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index 488fa9b2..56cea33b 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -262,8 +262,8 @@ circle-spacer border-inset)]) (values - (- tx (quotient (- ans-w tw) 2)) - (- ty (quotient (- ans-h th) 2)) + (- tx (quotient (ceiling (- ans-w tw)) 2)) + (- ty (quotient (ceiling (- ans-h th)) 2)) ans-w ans-h))) From 2a3bdeb69bafde751889139a6bd8cf62502d107a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 21:10:24 -0600 Subject: [PATCH 225/462] cocoa app file handler original commit: 4c22197dee2228714d64d79a5312594833df24f4 --- collects/mred/private/wx/cocoa/queue.rkt | 4 +++- collects/mred/private/wx/common/queue.rkt | 7 +++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 3557c15f..469e08d6 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -45,7 +45,9 @@ (if (ptr-equal? (selector openPreferences:) (tell #:type _SEL menuItem action)) (not (eq? (application-pref-handler) nothing-application-pref-handler)) - (super-tell #:type _BOOL validateMenuItem: menuItem))]) + (super-tell #:type _BOOL validateMenuItem: menuItem))] + [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) + (queue-file-event (string->path filename))]) (tellv app finishLaunching) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 452528fc..e7bc3052 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -44,6 +44,7 @@ queue-quit-event queue-prefs-event + queue-file-event begin-busy-cursor end-busy-cursor @@ -450,6 +451,12 @@ ;; called in event-pump thread (queue-event main-eventspace (application-pref-handler) 'med)) +(define (queue-file-event file) + ;; called in event-pump thread + (queue-event main-eventspace (lambda () + ((application-file-handler) file)) + 'med)) + (define (begin-busy-cursor) (let ([e (current-eventspace)]) (atomically From 9faffb56b7974bc8706f6646f89df1ebed2c3068 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 21:17:02 -0600 Subject: [PATCH 226/462] cocoa get-display-size: use screen with menu bar original commit: 158d119b12a0fe1a41211dcc7152a705c1935c37 --- collects/mred/private/wx/cocoa/procs.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 483e1121..22f38a0f 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -103,9 +103,12 @@ (set-box! xb 0) (set-box! yb 0)) (define (display-size xb yb v) - (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) - (set-box! xb (->long (NSSize-width (NSRect-size f)))) - (set-box! yb (->long (NSSize-height (NSRect-size f)))))) + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (tell #:type _NSRect screen frame)]) + (set-box! xb (->long (NSSize-width (NSRect-size f)))) + (set-box! yb (->long (NSSize-height (NSRect-size f)))))))) (define-appkit NSBeep (_fun -> _void)) (define (bell) (NSBeep)) From e5ef099a7c046a3ad40c29dc8d6c91fd65072ba5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 21:53:43 -0600 Subject: [PATCH 227/462] try to throttle cocoa event dequeue for key & mouse events original commit: 0f2ff1ff5dfd8c7cda603efcbf8b13382f86c581 --- collects/mred/private/wx/cocoa/const.rkt | 56 ++++++++++++++++++++++++ collects/mred/private/wx/cocoa/queue.rkt | 26 +++++++++-- 2 files changed, 78 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt index 82c37e0b..f8a39c5d 100644 --- a/collects/mred/private/wx/cocoa/const.rkt +++ b/collects/mred/private/wx/cocoa/const.rkt @@ -18,6 +18,62 @@ (define NSAnyEventMask #xffffffff) +(define NSLeftMouseDown 1) +(define NSLeftMouseUp 2) +(define NSRightMouseDown 3) +(define NSRightMouseUp 4) +(define NSMouseMoved 5) +(define NSLeftMouseDragged 6) +(define NSRightMouseDragged 7) +(define NSMouseEntered 8) +(define NSMouseExited 9) +(define NSKeyDown 10) +(define NSKeyUp 11) +(define NSFlagsChanged 12) +(define NSAppKitDefined 13) +(define NSSystemDefined 14) +(define NSApplicationDefined 15) +(define NSPeriodic 16) +(define NSCursorUpdate 17) +(define NSScrollWheel 22) +(define NSTabletPoint 23) +(define NSTabletProximity 24) +(define NSOtherMouseDown 25) +(define NSOtherMouseUp 26) +(define NSOtherMouseDragged 27) +(define NSEventTypeGesture 29) +(define NSEventTypeMagnify 30) +(define NSEventTypeSwipe 31) +(define NSEventTypeRotate 18) +(define NSEventTypeBeginGesture 19) +(define NSEventTypeEndGesture 20) + +(define MouseAndKeyEventMask + (bitwise-ior + (1 . << . NSLeftMouseDown) + (1 . << . NSLeftMouseUp) + (1 . << . NSRightMouseDown) + (1 . << . NSRightMouseUp) + (1 . << . NSMouseMoved) + (1 . << . NSLeftMouseDragged) + (1 . << . NSRightMouseDragged) + (1 . << . NSMouseEntered) + (1 . << . NSMouseExited) + (1 . << . NSKeyDown) + (1 . << . NSKeyUp) + (1 . << . NSScrollWheel) + (1 . << . NSTabletPoint) + (1 . << . NSTabletProximity) + (1 . << . NSOtherMouseDown) + (1 . << . NSOtherMouseUp) + (1 . << . NSOtherMouseDragged) + (1 . << . NSEventTypeGesture) + (1 . << . NSEventTypeMagnify) + (1 . << . NSEventTypeSwipe) + (1 . << . NSEventTypeRotate) + (1 . << . NSEventTypeBeginGesture) + (1 . << . NSEventTypeEndGesture))) + (define NSAlphaShiftKeyMask (1 . << . 16)) (define NSShiftKeyMask (1 . << . 17)) (define NSControlKeyMask (1 . << . 18)) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 469e08d6..8633d1ec 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -70,7 +70,6 @@ ;; ready to wake up (import-class NSEvent) -(define NSApplicationDefined 15) (define wake-evt (tell NSEvent otherEventWithType: #:type _int NSApplicationDefined @@ -181,6 +180,8 @@ (define events-suspended? #f) (define was-menu-bar #f) +(define avoid-mouse-key-until #f) + (define (check-menu-bar-click evt) (if (and evt (= 14 (tell #:type _NSUInteger evt type)) @@ -217,10 +218,17 @@ (when (and events-suspended? wait?) (set! was-menu-bar #f) (set! events-suspended? #f)) + (when (and avoid-mouse-key-until + ((current-inexact-milliseconds) . > . avoid-mouse-key-until)) + (set! avoid-mouse-key-until #f)) (begin0 (let ([evt (if events-suspended? #f - (tell app nextEventMatchingMask: #:type _NSUInteger NSAnyEventMask + (tell app nextEventMatchingMask: #:type _NSUInteger (if (and (not wait?) + avoid-mouse-key-until) + (- NSAnyEventMask + MouseAndKeyEventMask) + NSAnyEventMask) untilDate: (if wait? distantFuture #f) inMode: NSDefaultRunLoopMode dequeue: #:type _BOOL dequeue?))]) @@ -229,7 +237,15 @@ (or (not dequeue?) (let ([e (eventspace-hook (tell evt window))]) (if e - (begin + (let ([mouse-or-key? + (bitwise-bit-set? MouseAndKeyEventMask + (tell #:type _NSInteger evt type))]) + ;; If it's a mouse or key event, delay further + ;; dequeue of mouse and key events until this + ;; one can be handled. + (when mouse-or-key? + (set! avoid-mouse-key-until + (+ (current-inexact-milliseconds) 200.0))) (retain evt) (queue-event e (lambda () (call-as-nonatomic-retry-point @@ -237,7 +253,9 @@ ;; in atomic mode (with-autorelease (tellv app sendEvent: evt) - (release evt))))))) + (release evt)))) + (when mouse-or-key? + (set! avoid-mouse-key-until #f))))) (tellv app sendEvent: evt))) #t))) (tellv pool release)))) From 577095a355bc06d1ee8906791d47da44ec2f5b87 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Sep 2010 22:50:56 -0600 Subject: [PATCH 228/462] cocoa: don't over-poll for events original commit: 97a52a58bc011e26c72835fb71584fc2cc6f29ef --- collects/mred/private/wx/cocoa/queue.rkt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 8633d1ec..a5b02f24 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -268,8 +268,15 @@ (define (cocoa-start-event-pump) (thread (lambda () (let loop () + ;; Wait 50 msecs between event polling, unless nothing + ;; else is going on: + (sync/timeout 0.05 (system-idle-evt)) + ;; Wait until event is ready --- but waiting is implemented + ;; by polling: (sync queue-evt) + ;; Something is ready, so dispatch: (atomically (dispatch-all-ready)) + ;; Periodically free everything in the default allocation pool: (queue-autorelease-flush) (loop))))) From a540b1bf6f7564d5f7035dd6de0aa136b856615d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Sep 2010 08:00:23 -0600 Subject: [PATCH 229/462] display size and menu fixes original commit: b3613e999f9d9879a46775cf28315c955356689e --- collects/mred/private/wx/cocoa/frame.rkt | 3 ++- collects/mred/private/wx/cocoa/menu-bar.rkt | 6 +++++- collects/mred/private/wx/cocoa/procs.rkt | 11 ++++++++--- collects/mred/private/wx/gtk/menu.rkt | 3 ++- collects/mred/private/wxtop.rkt | 2 +- 5 files changed, 18 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 376fc7f5..e0a6da45 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -402,7 +402,8 @@ (define/override (move x y) (let ([x (if (= x -11111) (get-x) x)] [y (if (= y -11111) (get-y) y)]) - (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y))))) + (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y) + (get-menu-bar-height)))))) (define/override (center dir wrt) (let ([f (tell #:type _NSRect cocoa frame)] diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index df57b133..1facf8d9 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -10,7 +10,8 @@ "const.rkt" "queue.rkt") -(provide menu-bar%) +(provide menu-bar% + get-menu-bar-height) (import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) @@ -59,6 +60,9 @@ (and (<= x (NSPoint-x p) (+ x w)) (<= (- y h) (NSPoint-y p) y))))))) +(define (get-menu-bar-height) + (inexact->exact (floor (tell #:type _CGFloat cocoa-mb menuBarHeight)))) + (set-menu-bar-hooks! in-menu-bar-range) ;; Init menu bar diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 22f38a0f..4f8a8f5c 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -11,6 +11,7 @@ "finfo.rkt" ; file-creator-and-type "filedialog.rkt" "dc.rkt" + "menu-bar.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -101,12 +102,16 @@ (define (display-origin xb yb all?) (set-box! xb 0) - (set-box! yb 0)) -(define (display-size xb yb v) + (if all? + (set-box! yb 0) + (set-box! yb (get-menu-bar-height)))) +(define (display-size xb yb all?) (atomically (with-autorelease (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] - [f (tell #:type _NSRect screen frame)]) + [f (if all? + (tell #:type _NSRect screen frame) + (tell #:type _NSRect screen visibleFrame))]) (set-box! xb (->long (NSSize-width (NSRect-size f)))) (set-box! yb (->long (NSSize-height (NSRect-size f)))))))) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 9cb4a3a5..68d59b21 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -182,7 +182,8 @@ (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) (atomically - (let ([item-gtk ((if chckable? + (let ([item-gtk ((if (and chckable? + (not (help-str-or-submenu . is-a? . menu%))) gtk_check_menu_item_new_with_mnemonic gtk_menu_item_new_with_mnemonic) (fixup-mneumonic label))]) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 781a3278..80cb5d14 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -35,7 +35,7 @@ (opt-lambda ([full-screen? #f]) (let ([xb (box 0)] [yb (box 0)]) - (wx:display-size xb yb (if full-screen? 1 0)) + (wx:display-size xb yb full-screen?) (values (unbox xb) (unbox yb))))) (define get-display-left-top-inset From 57a851d11e90613e0483ecec26c86faa2af4b12e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Sep 2010 10:01:45 -0600 Subject: [PATCH 230/462] gtk: fix scroll change to not generate callback original commit: bdc9538244bb8da32ae0ed243318733a2911c280 --- collects/mred/private/wx/gtk/canvas.rkt | 48 ++++++++++++++++++------- 1 file changed, 36 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index a3ec1227..ef389076 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -173,7 +173,10 @@ (define (do-value-changed gtk dir) (let ([wx (gtk->wx gtk)]) (when wx - (queue-window-event wx (lambda () (send wx do-scroll dir))))) + (when (send wx deliver-scroll-callbacks?) + (queue-window-event wx (lambda () + (send wx do-scroll dir) + (flush-display)))))) #t) (define canvas% @@ -417,11 +420,23 @@ (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) (+ (* 2 margin) (if h? scroll-width 0)))) + (define suspend-scroll-callbacks? #f) + (define/public (deliver-scroll-callbacks?) (not suspend-scroll-callbacks?)) + (define/private (as-scroll-change thunk) + (atomically + (set! suspend-scroll-callbacks? #t) + (begin0 + (thunk) + (set! suspend-scroll-callbacks? #f)))) + + (define/private (configure-adj adj scroll-gtk len page pos) (when (and scroll-gtk adj) - (if (zero? len) - (gtk_adjustment_configure adj 0 0 1 1 1 1) - (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) + (as-scroll-change + (lambda () + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))) (define/public (set-scrollbars h-step v-step h-len v-len @@ -475,15 +490,22 @@ (dispatch which (lambda (adj) (let ([old (gtk_adjustment_get_page_size adj)]) (unless (= old v) - (gtk_adjustment_set_page_size adj v) - (gtk_adjustment_set_page_increment adj v) - (gtk_adjustment_set_upper adj (+ (- v old) - (gtk_adjustment_get_upper adj)))))))) + (as-scroll-change + (lambda () + (gtk_adjustment_set_page_size adj v) + (gtk_adjustment_set_page_increment adj v) + (gtk_adjustment_set_upper adj (+ (- v old) + (gtk_adjustment_get_upper adj)))))))))) (define/public (set-scroll-range which v) (dispatch which (lambda (adj) - (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) + (as-scroll-change + (lambda () + (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))))) (define/public (set-scroll-pos which v) - (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) + (dispatch which (lambda (adj) + (as-scroll-change + (lambda () + (gtk_adjustment_set_value adj v)))))) (define/public (get-scroll-page which) (->long (dispatch which gtk_adjustment_get_page_size 0))) @@ -546,8 +568,10 @@ (define/public (on-scroll e) (void)) (define/public (scroll x y) - (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) - (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) + (as-scroll-change + (lambda () + (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) + (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)))) (when auto-scroll? (refresh-for-autoscroll))) (def/public-unimplemented warp-pointer) From 37346734b81a1a7733a80a5a4df80231d8bd4b86 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Sep 2010 12:48:57 -0600 Subject: [PATCH 231/462] fix (different) refresh issues with both Gtk and Cocoa original commit: a1462d02557b50eabeba4fa3d6f10582416a7160 --- collects/mred/private/wx/cocoa/dc.rkt | 13 +++++++--- collects/mred/private/wx/gtk/dc.rkt | 37 ++++++++++++++------------- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 278d2cbb..2ecb3f47 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -60,7 +60,12 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; called atomically (not expecting exceptions) + ;; With Cocoa window-level delay doesn't stop + ;; displays; it blocks flushes to the screen. + ;; So leave the delay in place, and `end-delay' + ;; after displaying to the window (after which + ;; we'll be ready to flush the window), which + ;; is at then end of `do-backing-flush'. (send canvas queue-backing-flush)) (define/override (request-delay) @@ -92,6 +97,6 @@ (cairo_fill cr) (cairo_set_source cr s) (cairo_pattern_destroy s)) - (cairo_destroy cr)))))) - (tellv ctx restoreGraphicsState) - (send dc end-delay))) + (cairo_destroy cr)))) + (send dc end-delay))) + (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 01a141a2..5b223022 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -77,6 +77,7 @@ (define dc% (class backing-dc% (init [(cnvs canvas)]) + (inherit end-delay) (define canvas cnvs) (super-new) @@ -102,7 +103,9 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; called atomically (not expecting exceptions) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) (send canvas queue-backing-flush)) (define/override (request-delay) @@ -111,20 +114,18 @@ (cancel-flush-delay req)))) (define (do-backing-flush canvas dc win) - (begin0 - (send dc on-backing-flush - (lambda (bm) - (let ([w (box 0)] - [h (box 0)]) - (send canvas get-client-size w h) - (let ([cr (gdk_cairo_create win)]) - (let ([s (cairo_get_source cr)]) - (cairo_pattern_reference s) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 (unbox w) (unbox h)) - (cairo_fill cr) - (cairo_set_source cr s) - (cairo_pattern_destroy s)) - (cairo_destroy cr))))) - (send dc end-delay))) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cr (gdk_cairo_create win)]) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) From 663d3a839a56228bdecf02bea04b81808cea9865 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Sep 2010 19:44:50 -0600 Subject: [PATCH 232/462] canvas scroll and gauge range limit to 1000000 original commit: 6b606cb4e28cabf20b939d649dc89b2c54e1fbbf --- collects/mred/private/check.rkt | 2 +- collects/scribblings/gui/canvas-class.scrbl | 28 ++++++++++----------- collects/scribblings/gui/gauge-class.scrbl | 2 +- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/check.rkt b/collects/mred/private/check.rkt index 030901fd..717d099c 100644 --- a/collects/mred/private/check.rkt +++ b/collects/mred/private/check.rkt @@ -107,7 +107,7 @@ (define check-margin-integer (check-bounded-integer 0 1000 #f)) - (define check-gauge-integer (check-bounded-integer 1 10000 #f)) + (define check-gauge-integer (check-bounded-integer 1 1000000 #f)) (define (check-wheel-step cwho wheel-step) (when (and wheel-step diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 07b710d3..992c8e9c 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -91,7 +91,7 @@ The @scheme[gl-config] argument determines properties of an OpenGL } @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) - (integer-in 1 10000)]{ + (integer-in 1 1000000)]{ Get the current page step size of a manual scrollbar. The result is @scheme[0] if the scrollbar is not active or it is automatic. @@ -106,7 +106,7 @@ See also @defmethod[(get-scroll-pos [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 10000)]{ + (integer-in 0 1000000)]{ Gets the current value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -121,7 +121,7 @@ See also @defmethod[(get-scroll-range [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 10000)]{ + (integer-in 0 1000000)]{ Gets the current maximum value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -163,8 +163,8 @@ Gets the size in device units of the scrollable canvas area (as } -@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 10000) false/c)] - [vert-pixels (or/c (integer-in 1 10000) false/c)] +@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000) false/c)] + [vert-pixels (or/c (integer-in 1 1000000) false/c)] [h-value (real-in 0.0 1.0)] [v-value (real-in 0.0 1.0)]) void?]{ @@ -202,12 +202,12 @@ See also } -@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 10000) false/c)] - [v-length (or/c (integer-in 0 10000) false/c)] - [h-page (integer-in 1 10000)] - [v-page (integer-in 1 10000)] - [h-value (integer-in 0 10000)] - [v-value (integer-in 0 10000)]) +@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000) false/c)] + [v-length (or/c (integer-in 0 1000000) false/c)] + [h-page (integer-in 1 1000000)] + [v-page (integer-in 1 1000000)] + [h-value (integer-in 0 1000000)] + [v-value (integer-in 0 1000000)]) void?]{ Enables and initializes manual scrollbars for the canvas. A @@ -311,7 +311,7 @@ See also @defmethod[(set-scroll-page [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 1 10000)]) + [value (integer-in 1 1000000)]) void?]{ Set the current page step size of a manual scrollbar. (This method has @@ -328,7 +328,7 @@ See also @defmethod[(set-scroll-pos [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 10000)]) + [value (integer-in 0 1000000)]) void?]{ Sets the current value of a manual scrollbar. (This method has no @@ -348,7 +348,7 @@ See also @defmethod[(set-scroll-range [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 10000)]) + [value (integer-in 0 1000000)]) void?]{ Sets the current maximum value of a manual scrollbar. (This method has diff --git a/collects/scribblings/gui/gauge-class.scrbl b/collects/scribblings/gui/gauge-class.scrbl index a5f1ea3d..cd672922 100644 --- a/collects/scribblings/gui/gauge-class.scrbl +++ b/collects/scribblings/gui/gauge-class.scrbl @@ -11,7 +11,7 @@ of the gauge. @defconstructor[([label (or/c label-string? false/c)] - [range (integer-in 1 10000)] + [range (integer-in 1 1000000)] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [style (listof (one-of/c 'horizontal 'vertical From 066057f0b4c9e563c0cddb6095a51724e9040275 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 08:52:48 -0600 Subject: [PATCH 233/462] gtk default frame icon original commit: 26036ac55e2da3c8f30906bfa53f3c4f52f8f38e --- collects/mred/private/wx/gtk/frame.rkt | 31 +++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 2a0bc0ba..93a79666 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -1,6 +1,10 @@ #lang scheme/base -(require scheme/foreign - scheme/class +(require ffi/unsafe + racket/class + racket/promise + racket/runtime-path + racket/draw/bitmap + (for-syntax (only-in racket/base quote)) "../../syntax.rkt" "../../lock.rkt" "utils.rkt" @@ -11,8 +15,8 @@ "widget.rkt" "procs.rkt" "cursor.rkt" + "pixbuf.rkt" "../common/queue.rkt") -(unsafe!) (provide frame%) @@ -21,6 +25,8 @@ (define GDK_GRAVITY_NORTH_WEST 1) (define GDK_GRAVITY_STATIC 10) +(define _GList (_cpointer/null 'GList)) +(define-glib g_list_insert (_fun _GList _pointer _int -> _GList)) (define-gtk gtk_window_new (_fun _int -> _GtkWidget)) (define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) @@ -37,6 +43,7 @@ -> _void -> (values x y))) (define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) +(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void)) (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) @@ -93,6 +100,21 @@ (GdkEventWindowState-new_window_state evt)))) #f)) +(define-runtime-path plt-16x16-file '(lib "icons/plt-16x16.png")) +(define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png")) +(define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png")) + +(define icon-list + (delay + (let ([icons (map + (lambda (fn) + (bitmap->pixbuf (make-object bitmap% fn 'png/alpha))) + (list plt-16x16-file + plt-32x32-file + plt-48x48-file))]) + (for/fold ([l #f]) ([i (in-list icons)]) + (g_list_insert l i -1))))) + (define frame% (class (client-size-mixin window%) (init parent @@ -121,6 +143,9 @@ (gtk_widget_show vbox-gtk) (gtk_widget_show panel-gtk) + (unless is-dialog? + (gtk_window_set_icon_list gtk (force icon-list))) + (define/override (get-client-gtk) panel-gtk) (define/override (get-window-gtk) gtk) From 65bb68bc8ff0362af0608ea470cf12ab89198c68 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 09:05:03 -0600 Subject: [PATCH 234/462] gtk frame% set-icon original commit: ece405106b34fd772cda6ab43f9c0a50c86b3d4d --- collects/mred/private/wx/gtk/frame.rkt | 52 +++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 93a79666..d35ac533 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -3,7 +3,7 @@ racket/class racket/promise racket/runtime-path - racket/draw/bitmap + racket/draw (for-syntax (only-in racket/base quote)) "../../syntax.rkt" "../../lock.rkt" @@ -27,6 +27,7 @@ (define _GList (_cpointer/null 'GList)) (define-glib g_list_insert (_fun _GList _pointer _int -> _GList)) +(define-glib g_list_free (_fun _GList -> _void)) (define-gtk gtk_window_new (_fun _int -> _GtkWidget)) (define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) @@ -104,7 +105,7 @@ (define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png")) (define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png")) -(define icon-list +(define icon-pixbufs+glist (delay (let ([icons (map (lambda (fn) @@ -112,8 +113,12 @@ (list plt-16x16-file plt-32x32-file plt-48x48-file))]) - (for/fold ([l #f]) ([i (in-list icons)]) - (g_list_insert l i -1))))) + (cons + ;; keep pixbuf pointers to avoid GC: + icons + ;; a glist: + (for/fold ([l #f]) ([i (in-list icons)]) + (g_list_insert l i -1)))))) (define frame% (class (client-size-mixin window%) @@ -144,7 +149,7 @@ (gtk_widget_show panel-gtk) (unless is-dialog? - (gtk_window_set_icon_list gtk (force icon-list))) + (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) (define/override (get-client-gtk) panel-gtk) (define/override (get-window-gtk) gtk) @@ -303,7 +308,42 @@ (define/augment (is-enabled-to-root?) #t) - (define/public (set-icon bm mask [mode 'both]) (void)) ;; FIXME + (define big-icon #f) + (define small-icon #f) + (define/public (set-icon bm mask [mode 'both]) + (let ([bm (if mask + (let* ([nbm (make-object bitmap% + (send bm get-width) + (send bm get-height) + #f + #t)] + [dc (make-object bitmap-dc% nbm)]) + (send dc draw-bitmap bm 0 0 + 'solid (make-object color% "black") + mask) + (send dc set-bitmap #f) + nbm) + bm)]) + (case mode + [(small) (set! small-icon bm)] + [(big) (set! big-icon bm)] + [(both) + (set! small-icon bm) + (set! big-icon bm)]) + (let ([small-pixbuf + (if small-icon + (bitmap->pixbuf small-icon) + (car (car (force icon-pixbufs+glist))))] + [big-pixbufs + (if big-icon + (list (bitmap->pixbuf big-icon)) + (cdr (car (force icon-pixbufs+glist))))]) + (atomically + (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf + big-pixbufs)]) + (g_list_insert l i -1))]) + (gtk_window_set_icon_list gtk l) + (g_list_free l)))))) (define/override (call-pre-on-event w e) (pre-on-event w e)) From d8206ac1fb39dfbf14f0f4f479e83129e6d46402 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 09:39:22 -0600 Subject: [PATCH 235/462] cocoa toolbar button and some unimplemented clean-up original commit: 7e8a08cdd88c7f483cdca35d259e49c1abc6e049 --- collects/mred/private/wx/cocoa/frame.rkt | 21 ++++++++++++++++++--- collects/mred/private/wx/cocoa/menu-bar.rkt | 1 - collects/mred/private/wx/gtk/filedialog.rkt | 6 ------ collects/mred/private/wx/gtk/frame.rkt | 4 ---- collects/mred/private/wx/gtk/menu-bar.rkt | 1 - collects/mred/private/wx/win32/frame.rkt | 3 --- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index e0a6da45..76d206bb 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -21,9 +21,11 @@ ;; ---------------------------------------- (import-class NSWindow NSGraphicsContext NSMenu NSPanel - NSApplication NSAutoreleasePool NSScreen) + NSApplication NSAutoreleasePool NSScreen + NSToolbar) (define NSWindowCloseButton 0) +(define NSWindowToolbarButton 3) (define front #f) @@ -81,7 +83,14 @@ (send empty-mb install) (send wx notify-responder #f) (queue-window-event wx (lambda () - (send wx on-activate #f))))))]) + (send wx on-activate #f))))))] + [-a _void (toggleToolbarShown: [_id sender]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx + (lambda () (send wx on-toolbar-click)))))) + (void)]) (define-objc-class MyWindow NSWindow #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) @@ -156,6 +165,12 @@ (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) + (when (memq 'toolbar-button style) + (atomically + (let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")]) + (tellv cocoa setToolbar: tb) + (tellv tb setVisible: #:type _BOOL #f)))) + (move -11111 (if (= y -11111) 0 y)) (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) @@ -459,7 +474,7 @@ (define/public (on-menu-click) (void)) - (def/public-unimplemented on-toolbar-click) + (define/public (on-toolbar-click) (void)) (def/public-unimplemented on-menu-command) (def/public-unimplemented on-mdi-activate) (def/public-unimplemented on-close) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 1facf8d9..e72947f9 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -119,7 +119,6 @@ (defclass menu-bar% object% (define menus null) - (def/public-unimplemented number) (define/public (enable-top pos on?) (set-box! (cddr (list-ref menus pos)) on?) (when (eq? current-mb this) diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt index c26bd77b..535ae829 100644 --- a/collects/mred/private/wx/gtk/filedialog.rkt +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -138,9 +138,3 @@ (free-immobile-cell cell) ;; FIXME : don't leak (gtk_widget_hide dlg-gtk) (unbox response-box))) - -(define (id-to-menu-item i) i) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) -(define-unimplemented show-print-setup) -(define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d35ac533..7cf3642d 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -371,10 +371,6 @@ (set! is-modified? (and mod? #t)) (set-title saved-title))) - (define/public (create-status-line) (void)) - (define/public (set-status-text s) (void)) - (def/public-unimplemented status-line-exists?) - (define waiting-cursor? #f) (define/public (set-wait-cursor-mode on?) (set! waiting-cursor? on?) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 183d99ae..4771e446 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -114,7 +114,6 @@ (gtk_label_set_text_with_mnemonic (gtk_bin_get_child item-gtk) (fixup-mneumonic str))))) - (def/public-unimplemented number) (def/public-unimplemented enable-top) (define/public (delete which pos) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index a9553e40..4d9053ad 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -16,12 +16,9 @@ (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) - (def/public-unimplemented create-status-line) (def/public-unimplemented is-maximized?) (def/public-unimplemented maximize) - (def/public-unimplemented status-line-exists?) (def/public-unimplemented iconized?) - (def/public-unimplemented set-status-text) (def/public-unimplemented get-menu-bar) (def/public-unimplemented set-menu-bar) (def/public-unimplemented set-icon) From dd79f9bae7b1dd9e25418a2ed69e467bb6c9f91f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 10:51:26 -0600 Subject: [PATCH 236/462] clean up unused original commit: 23f0296cb944cbd253ed22fc0beb2ae4f2e04e29 --- collects/mred/mred.rkt | 4 --- collects/mred/private/kernel.rkt | 11 +++++++- collects/mred/private/misc.rkt | 3 +- collects/mred/private/mrmenu.rkt | 4 +-- collects/mred/private/wx/cocoa/platform.rkt | 20 ++----------- collects/mred/private/wx/cocoa/procs.rkt | 26 +++-------------- collects/mred/private/wx/gtk/platform.rkt | 20 ++----------- collects/mred/private/wx/gtk/procs.rkt | 25 +++-------------- collects/mred/private/wx/platform.rkt | 18 ++---------- collects/mred/private/wx/win32/platform.rkt | 20 ++----------- collects/mred/private/wx/win32/procs.rkt | 31 +++------------------ collects/mred/private/wxtextfield.rkt | 2 +- 12 files changed, 34 insertions(+), 150 deletions(-) diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 65be0c5a..d4113ebf 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -42,10 +42,6 @@ "private/dynamic.ss" "private/check.ss") - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; These functions are re-implemented in scheme/gui/base ;; and racket/gui/base to attach those names, instead of diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 114af2bf..61b01afc 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -7,11 +7,15 @@ "wx/common/cursor.rkt" "wx/common/gl-config.rkt" "wx/common/procs.rkt" + "wx/common/handlers.rkt" racket/class racket/draw) (define gl-context<%> (class->interface gl-context%)) +(define (key-symbol-to-integer k) + (error 'key-symbol-to-integer "not yet implemented")) + (provide (all-from-out "wx/platform.rkt") clipboard<%> gl-context<%> @@ -37,4 +41,9 @@ get-top-level-windows begin-busy-cursor is-busy? - end-busy-cursor) + end-busy-cursor + key-symbol-to-integer + application-file-handler + application-quit-handler + application-about-handler + application-pref-handler) diff --git a/collects/mred/private/misc.rkt b/collects/mred/private/misc.rkt index 964b66c7..4bc03500 100644 --- a/collects/mred/private/misc.rkt +++ b/collects/mred/private/misc.rkt @@ -10,7 +10,8 @@ play-sound timer%) - ;; Currently only used for PS print and preview + ;; Formerly used for PS print and preview: + #; (wx:set-executer (let ([orig-err (current-error-port)]) (lambda (prog . args) diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 907e4250..6c42f9ff 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -466,6 +466,4 @@ (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) - (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p))) - - (wx:set-menu-tester (lambda (m) (is-a? m popup-menu%)))) + (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 1160f908..b912d0f3 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -10,7 +10,6 @@ "frame.rkt" "gauge.rkt" "gl-context.rkt" - "group-box.rkt" "group-panel.rkt" "item.rkt" "list-box.rkt" @@ -22,7 +21,6 @@ "printer-dc.rkt" "radio-box.rkt" "slider.rkt" - "tab-group.rkt" "tab-panel.rkt" "window.rkt" "procs.rkt") @@ -40,7 +38,6 @@ frame% gauge% gl-context% - group-box% group-panel% item% list-box% @@ -52,7 +49,6 @@ printer-dc% radio-box% slider% - tab-group% tab-panel% window% can-show-print-setup? @@ -72,34 +68,22 @@ fill-private-color cancel-quit get-control-font-size - key-symbol-to-integer - draw-tab-base - draw-tab - set-combo-box-font get-double-click-time run-printout file-creator-and-type send-event - set-executer - set-dialogs location->window - set-menu-tester - in-atomic-region shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit find-graphical-system-path - check-for-break play-sound get-panel-background get-font-from-user get-color-from-user - application-pref-handler - application-about-handler - application-quit-handler - application-file-handler special-option-key special-control-key get-highlight-background-color get-highlight-text-color - make-screen-bitmap)) + make-screen-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 4f8a8f5c..c25e3801 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -24,23 +24,14 @@ get-font-from-user get-panel-background play-sound - check-for-break find-graphical-system-path register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? - in-atomic-region - set-menu-tester - set-dialogs - set-executer send-event file-creator-and-type run-printout get-double-click-time - set-combo-box-font - draw-tab - draw-tab-base - key-symbol-to-integer get-control-font-size cancel-quit fill-private-color @@ -61,7 +52,8 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color - make-screen-bitmap) + make-screen-bitmap + check-for-break) (import-class NSScreen NSCursor) @@ -70,36 +62,26 @@ (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) -(define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [x #f]) #f) -(define-unimplemented in-atomic-region) -(define (set-menu-tester proc) - (void)) -(define (set-dialogs . args) - (void)) -(define (set-executer proc) - (void)) (define-unimplemented send-event) (define (begin-refresh-sequence) (void)) (define (end-refresh-sequence) (void)) (define-unimplemented run-printout) (define (get-double-click-time) 500) -(define (set-combo-box-font f) (void)) -(define-unimplemented draw-tab) -(define-unimplemented draw-tab-base) -(define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 13) (define (cancel-quit) (void)) (define-unimplemented fill-private-color) (define-unimplemented write-resource) (define-unimplemented get-resource) +(define (check-for-break) #f) + (define (display-origin xb yb all?) (set-box! xb 0) (if all? diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index f20c1811..ae282dda 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -10,7 +10,6 @@ "frame.rkt" "gauge.rkt" "gl-context.rkt" - "group-box.rkt" "group-panel.rkt" "item.rkt" "list-box.rkt" @@ -22,7 +21,6 @@ "printer-dc.rkt" "radio-box.rkt" "slider.rkt" - "tab-group.rkt" "tab-panel.rkt" "window.rkt" "procs.rkt") @@ -40,7 +38,6 @@ frame% gauge% gl-context% - group-box% group-panel% item% list-box% @@ -52,7 +49,6 @@ printer-dc% radio-box% slider% - tab-group% tab-panel% window% can-show-print-setup? @@ -72,34 +68,22 @@ fill-private-color cancel-quit get-control-font-size - key-symbol-to-integer - draw-tab-base - draw-tab - set-combo-box-font get-double-click-time run-printout file-creator-and-type send-event - set-executer - set-dialogs location->window - set-menu-tester - in-atomic-region shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit find-graphical-system-path - check-for-break play-sound get-panel-background get-font-from-user get-color-from-user - application-pref-handler - application-about-handler - application-quit-handler - application-file-handler special-option-key special-control-key get-highlight-background-color get-highlight-text-color - make-screen-bitmap)) + make-screen-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 99cfbf55..8455301b 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -16,31 +16,19 @@ (provide special-control-key special-option-key - application-file-handler - application-quit-handler - application-about-handler - application-pref-handler get-color-from-user get-font-from-user get-panel-background play-sound - check-for-break find-graphical-system-path register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? - in-atomic-region - set-menu-tester location->window - set-dialogs - set-executer send-event file-creator-and-type run-printout get-double-click-time - set-combo-box-font - draw-tab - draw-tab-base key-symbol-to-integer get-control-font-size cancel-quit @@ -62,7 +50,8 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color - make-screen-bitmap) + make-screen-bitmap + check-for-break) (define-unimplemented special-control-key) (define (special-option-key on?) (void)) @@ -70,18 +59,13 @@ (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) -(define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [mbar? #f]) #t) -(define-unimplemented in-atomic-region) -(define (set-menu-tester proc) (void)) (define-unimplemented location->window) -(define (set-dialogs . args) (void)) -(define (set-executer e) (void)) (define-unimplemented send-event) (define file-creator-and-type (case-lambda @@ -89,9 +73,6 @@ [(path) (values #"????" #"????")])) (define-unimplemented run-printout) (define (get-double-click-time) 250) -(define (set-combo-box-font f) (void)) -(define-unimplemented draw-tab) -(define-unimplemented draw-tab-base) (define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 10) ;; FIXME (define-unimplemented cancel-quit) @@ -140,3 +121,5 @@ (if (eq? 'unix (system-type)) (make-object x11-bitmap% w h #f) (make-object bitmap% w h #f #t))) + +(define (check-for-break) #f) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 53f1e0f0..2507a56f 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -18,7 +18,6 @@ frame% gauge% gl-context% - group-box% group-panel% item% list-box% @@ -30,7 +29,6 @@ printer-dc% radio-box% slider% - tab-group% tab-panel% window% can-show-print-setup? @@ -50,35 +48,23 @@ fill-private-color cancel-quit get-control-font-size - key-symbol-to-integer - draw-tab-base - draw-tab - set-combo-box-font get-double-click-time run-printout file-creator-and-type send-event - set-executer - set-dialogs location->window - set-menu-tester - in-atomic-region shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit find-graphical-system-path - check-for-break play-sound get-panel-background get-font-from-user get-color-from-user - application-pref-handler - application-about-handler - application-quit-handler - application-file-handler special-option-key special-control-key get-highlight-background-color get-highlight-text-color - make-screen-bitmap) + make-screen-bitmap + check-for-break) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 94abbf66..0e8ec5c9 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -9,7 +9,6 @@ "frame.rkt" "gauge.rkt" "gl-context.rkt" - "group-box.rkt" "group-panel.rkt" "item.rkt" "list-box.rkt" @@ -21,7 +20,6 @@ "printer-dc.rkt" "radio-box.rkt" "slider.rkt" - "tab-group.rkt" "tab-panel.rkt" "window.rkt" "procs.rkt") @@ -39,7 +37,6 @@ frame% gauge% gl-context% - group-box% group-panel% item% list-box% @@ -51,7 +48,6 @@ printer-dc% radio-box% slider% - tab-group% tab-panel% window% can-show-print-setup? @@ -71,34 +67,22 @@ fill-private-color cancel-quit get-control-font-size - key-symbol-to-integer - draw-tab-base - draw-tab - set-combo-box-font get-double-click-time run-printout file-creator-and-type send-event - set-executer - set-dialogs location->window - set-menu-tester - in-atomic-region shortcut-visible-in-label? unregister-collecting-blit register-collecting-blit find-graphical-system-path - check-for-break play-sound get-panel-background get-font-from-user get-color-from-user - application-pref-handler - application-about-handler - application-quit-handler - application-file-handler special-option-key special-control-key get-highlight-background-color get-highlight-text-color - make-screen-bitmap)) + make-screen-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index ecb0535c..26ba0e07 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -4,32 +4,19 @@ (provide special-control-key special-option-key - application-file-handler - application-quit-handler - application-about-handler - application-pref-handler get-color-from-user get-font-from-user get-panel-background play-sound - check-for-break find-graphical-system-path register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? - in-atomic-region - set-menu-tester location->window - set-dialogs - set-executer send-event file-creator-and-type run-printout get-double-click-time - set-combo-box-font - draw-tab - draw-tab-base - key-symbol-to-integer get-control-font-size cancel-quit fill-private-color @@ -50,36 +37,24 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color - make-screen-bitmap) + make-screen-bitmap + check-for-break) (define-unimplemented special-control-key) (define-unimplemented special-option-key) -(define-unimplemented application-file-handler) -(define-unimplemented application-quit-handler) -(define-unimplemented application-about-handler) -(define-unimplemented application-pref-handler) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define-unimplemented get-panel-background) (define-unimplemented play-sound) -(define-unimplemented check-for-break) (define-unimplemented find-graphical-system-path) (define-unimplemented register-collecting-blit) (define-unimplemented unregister-collecting-blit) (define-unimplemented shortcut-visible-in-label?) -(define-unimplemented in-atomic-region) -(define-unimplemented set-menu-tester) (define-unimplemented location->window) -(define-unimplemented set-dialogs) -(define-unimplemented set-executer) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) (define-unimplemented run-printout) (define-unimplemented get-double-click-time) -(define-unimplemented set-combo-box-font) -(define-unimplemented draw-tab) -(define-unimplemented draw-tab-base) -(define-unimplemented key-symbol-to-integer) (define-unimplemented get-control-font-size) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) @@ -104,3 +79,5 @@ (define-unimplemented get-highlight-background-color) (define-unimplemented get-highlight-text-color) (define-unimplemented make-screen-bitmap) + +(define (check-for-break) #f) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index f958b5a7..d7a618d7 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -160,7 +160,7 @@ (unless horiz? (send p alignment 'left 'top)) (unless multi? (stretchable-in-y #f)) ;; For Windows: - (wx:set-combo-box-font font) + ; (wx:set-combo-box-font font) (spacing 3)) (private-field [l (and label From b3267c7dba335e6ade6c3e0961596c2f0b59d855 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 18:05:11 -0600 Subject: [PATCH 237/462] gtk on-drop-file original commit: 24b016c8d5918116a1c2eeebb3e14baa4371083b --- collects/mred/private/wx/gtk/clipboard.rkt | 5 ++- collects/mred/private/wx/gtk/window.rkt | 44 ++++++++++++++++++++-- 2 files changed, 44 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index f396badc..9133b86c 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -11,7 +11,10 @@ (unsafe!) (provide clipboard-driver% - has-x-selection?) + has-x-selection? + _GtkSelectionData + gtk_selection_data_get_length + gtk_selection_data_get_data) (define (has-x-selection?) #t) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 7a36b67b..30738906 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -9,13 +9,15 @@ "../common/queue.rkt" "../common/local.rkt" "../common/delay.rkt" + "../common/bstr.rkt" "keycode.rkt" "keymap.rkt" "queue.rkt" "utils.rkt" "const.rkt" "types.rkt" - "widget.rkt") + "widget.rkt" + "clipboard.rkt") (provide window% gtk->wx @@ -96,6 +98,30 @@ (define (widget-window gtk) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) +(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void)) +(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void)) +(define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void)) + +(define GTK_DEST_DEFAULT_ALL #x07) +(define GDK_ACTION_COPY (arithmetic-shift 1 1)) + +(define-signal-handler connect-drag-data-received "drag-data-received" + (_fun _GtkWidget _pointer _int _int _GtkSelectionData _uint _uint -> _void) + (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 (bytes->path (cadr m))]) + (send wx on-drop-file path)))))])))))) + ;; ---------------------------------------- (define-signal-handler connect-focus-in "focus-in-event" @@ -497,8 +523,17 @@ (gtk_widget_set_sensitive gtk on?)) (define/public (is-window-enabled?) enabled?) - (define/public (drag-accept-files on?) (void)) - + (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))) + (define/public (set-focus) (gtk_widget_grab_focus (get-client-gtk))) @@ -571,7 +606,8 @@ (define/public (paint-children) (void)) - (def/public-unimplemented on-drop-file) + (define/public (on-drop-file path) (void)) + (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) From b92d69334347e971a19c2c52e5348cee394644d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 18:19:42 -0600 Subject: [PATCH 238/462] gtk clipboard repair original commit: abf1805d4257c05c7c7d40535414a0dcfd901a94 --- collects/mred/private/wx/gtk/clipboard.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 9133b86c..13bdb2b8 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -127,7 +127,7 @@ (define/public (replaced s-box) ;; Called in Gtk event-dispatch thread --- atomically with respect ;; to any other thread - (when (eq? s-box self-box) + (when (ptr-equal? s-box self-box) (set! self-box #f) (let ([c client]) (when c From 18ad972f3f0781e221497e4a1b7622333857f4de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Sep 2010 06:56:43 -0600 Subject: [PATCH 239/462] win32 beginnings original commit: aaf06368175911b92579af1666bfe6262aaf99fe --- collects/mred/private/wx/win32/button.rkt | 28 +- collects/mred/private/wx/win32/canvas.rkt | 2 + collects/mred/private/wx/win32/const.rkt | 413 ++++++++++++++++++++ collects/mred/private/wx/win32/cursor.rkt | 2 + collects/mred/private/wx/win32/frame.rkt | 88 ++++- collects/mred/private/wx/win32/icons.rkt | 13 + collects/mred/private/wx/win32/init.rkt | 7 + collects/mred/private/wx/win32/panel.rkt | 27 +- collects/mred/private/wx/win32/platform.rkt | 3 +- collects/mred/private/wx/win32/procs.rkt | 30 +- collects/mred/private/wx/win32/queue.rkt | 62 +++ collects/mred/private/wx/win32/types.rkt | 83 ++++ collects/mred/private/wx/win32/utils.rkt | 17 + collects/mred/private/wx/win32/window.rkt | 156 +++++++- collects/mred/private/wx/win32/wndclass.rkt | 112 ++++++ 15 files changed, 999 insertions(+), 44 deletions(-) create mode 100644 collects/mred/private/wx/win32/const.rkt create mode 100644 collects/mred/private/wx/win32/icons.rkt create mode 100644 collects/mred/private/wx/win32/init.rkt create mode 100644 collects/mred/private/wx/win32/queue.rkt create mode 100644 collects/mred/private/wx/win32/types.rkt create mode 100644 collects/mred/private/wx/win32/utils.rkt create mode 100644 collects/mred/private/wx/win32/wndclass.rkt diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index d81e35ab..478b6af4 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -1,10 +1,32 @@ #lang scheme/base (require scheme/class "../../syntax.rkt" - "item.rkt") + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt") (provide button%) (defclass button% item% - (def/public-unimplemented set-border) - (super-new)) + (inherit auto-size) + + (init parent cb label x y w h style font) + + (super-new [parent parent] + [win32 + (CreateWindowExW 0 + "BUTTON" + label + (bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-win32) + #f + hInstance + #f)] + [style style]) + + (auto-size label 50 14) + + (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 141dd440..78456edb 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -27,4 +27,6 @@ (def/public-unimplemented on-char) (def/public-unimplemented on-event) (def/public-unimplemented on-paint) + (def/public-unimplemented begin-refresh-sequence) + (def/public-unimplemented end-refresh-sequence) (super-new)) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt new file mode 100644 index 00000000..b3cbc40f --- /dev/null +++ b/collects/mred/private/wx/win32/const.rkt @@ -0,0 +1,413 @@ +#lang scheme/base +(provide (all-defined-out)) + +(define WM_NULL #x0000) +(define WM_CREATE #x0001) +(define WM_DESTROY #x0002) +(define WM_MOVE #x0003) +(define WM_SIZE #x0005) + +(define WM_ACTIVATE #x0006) + + +;; WM_ACTIVATE state values +(define WA_INACTIVE 0) +(define WA_ACTIVE 1) +(define WA_CLICKACTIVE 2) + +(define WM_SETFOCUS #x0007) +(define WM_KILLFOCUS #x0008) +(define WM_ENABLE #x000A) +(define WM_SETREDRAW #x000B) +(define WM_SETTEXT #x000C) +(define WM_GETTEXT #x000D) +(define WM_GETTEXTLENGTH #x000E) +(define WM_PAINT #x000F) +(define WM_CLOSE #x0010) +(define WM_QUIT #x0012) +(define WM_ERASEBKGND #x0014) +(define WM_SYSCOLORCHANGE #x0015) +(define WM_SHOWWINDOW #x0018) +(define WM_WININICHANGE #x001A) +(define WM_SETTINGCHANGE WM_WININICHANGE) + +(define WM_DEVMODECHANGE #x001B) +(define WM_ACTIVATEAPP #x001C) +(define WM_FONTCHANGE #x001D) +(define WM_TIMECHANGE #x001E) +(define WM_CANCELMODE #x001F) +(define WM_SETCURSOR #x0020) +(define WM_MOUSEACTIVATE #x0021) +(define WM_CHILDACTIVATE #x0022) +(define WM_QUEUESYNC #x0023) + +(define WM_GETMINMAXINFO #x0024) + +(define WM_PAINTICON #x0026) +(define WM_ICONERASEBKGND #x0027) +(define WM_NEXTDLGCTL #x0028) +(define WM_SPOOLERSTATUS #x002A) +(define WM_DRAWITEM #x002B) +(define WM_MEASUREITEM #x002C) +(define WM_DELETEITEM #x002D) +(define WM_VKEYTOITEM #x002E) +(define WM_CHARTOITEM #x002F) +(define WM_SETFONT #x0030) +(define WM_GETFONT #x0031) +(define WM_SETHOTKEY #x0032) +(define WM_GETHOTKEY #x0033) +(define WM_QUERYDRAGICON #x0037) +(define WM_COMPAREITEM #x0039) +(define WM_GETOBJECT #x003D) +(define WM_COMPACTING #x0041) +(define WM_WINDOWPOSCHANGING #x0046) +(define WM_WINDOWPOSCHANGED #x0047) + +(define WM_POWER #x0048) + +;; wParam for WM_POWER window message and DRV_POWER driver notification +(define PWR_OK 1) +(define PWR_FAIL -1) +(define PWR_SUSPENDREQUEST 1) +(define PWR_SUSPENDRESUME 2) +(define PWR_CRITICALRESUME 3) + +(define WM_COPYDATA #x004A) +(define WM_CANCELJOURNAL #x004B) + +(define WM_NOTIFY #x004E) +(define WM_INPUTLANGCHANGEREQUEST #x0050) +(define WM_INPUTLANGCHANGE #x0051) +(define WM_TCARD #x0052) +(define WM_HELP #x0053) +(define WM_USERCHANGED #x0054) +(define WM_NOTIFYFORMAT #x0055) + +(define NFR_ANSI 1) +(define NFR_UNICODE 2) +(define NF_QUERY 3) +(define NF_REQUERY 4) + +(define WM_CONTEXTMENU #x007B) +(define WM_STYLECHANGING #x007C) +(define WM_STYLECHANGED #x007D) +(define WM_DISPLAYCHANGE #x007E) +(define WM_GETICON #x007F) +(define WM_SETICON #x0080) + +(define WM_NCCREATE #x0081) +(define WM_NCDESTROY #x0082) +(define WM_NCCALCSIZE #x0083) +(define WM_NCHITTEST #x0084) +(define WM_NCPAINT #x0085) +(define WM_NCACTIVATE #x0086) +(define WM_GETDLGCODE #x0087) +(define WM_NCMOUSEMOVE #x00A0) +(define WM_NCLBUTTONDOWN #x00A1) +(define WM_NCLBUTTONUP #x00A2) +(define WM_NCLBUTTONDBLCLK #x00A3) +(define WM_NCRBUTTONDOWN #x00A4) +(define WM_NCRBUTTONUP #x00A5) +(define WM_NCRBUTTONDBLCLK #x00A6) +(define WM_NCMBUTTONDOWN #x00A7) +(define WM_NCMBUTTONUP #x00A8) +(define WM_NCMBUTTONDBLCLK #x00A9) + +(define WM_NCXBUTTONDOWN #x00AB) +(define WM_NCXBUTTONUP #x00AC) +(define WM_NCXBUTTONDBLCLK #x00AD) + +(define WM_INPUT #x00FF) + +(define WM_KEYFIRST #x0100) +(define WM_KEYDOWN #x0100) +(define WM_KEYUP #x0101) +(define WM_CHAR #x0102) +(define WM_DEADCHAR #x0103) +(define WM_SYSKEYDOWN #x0104) +(define WM_SYSKEYUP #x0105) +(define WM_SYSCHAR #x0106) +(define WM_SYSDEADCHAR #x0107) +(define WM_UNICHAR #x0109) +(define WM_KEYLAST #x0109) +(define UNICODE_NOCHAR #xFFFF) + +(define WM_IME_STARTCOMPOSITION #x010D) +(define WM_IME_ENDCOMPOSITION #x010E) +(define WM_IME_COMPOSITION #x010F) +(define WM_IME_KEYLAST #x010F) + +(define WM_INITDIALOG #x0110) +(define WM_COMMAND #x0111) +(define WM_SYSCOMMAND #x0112) +(define WM_TIMER #x0113) +(define WM_HSCROLL #x0114) +(define WM_VSCROLL #x0115) +(define WM_INITMENU #x0116) +(define WM_INITMENUPOPUP #x0117) +(define WM_MENUSELECT #x011F) +(define WM_MENUCHAR #x0120) +(define WM_ENTERIDLE #x0121) +(define WM_MENURBUTTONUP #x0122) +(define WM_MENUDRAG #x0123) +(define WM_MENUGETOBJECT #x0124) +(define WM_UNINITMENUPOPUP #x0125) +(define WM_MENUCOMMAND #x0126) + +(define WM_CHANGEUISTATE #x0127) +(define WM_UPDATEUISTATE #x0128) +(define WM_QUERYUISTATE #x0129) + +;; LOWORD(wParam) values in WM_*UISTATE* +(define UIS_SET 1) +(define UIS_CLEAR 2) +(define UIS_INITIALIZE 3) + +;; HIWORD(wParam) values in WM_*UISTATE* +(define UISF_HIDEFOCUS #x1) +(define UISF_HIDEACCEL #x2) +(define UISF_ACTIVE #x4) + +(define WM_CTLCOLORMSGBOX #x0132) +(define WM_CTLCOLOREDIT #x0133) +(define WM_CTLCOLORLISTBOX #x0134) +(define WM_CTLCOLORBTN #x0135) +(define WM_CTLCOLORDLG #x0136) +(define WM_CTLCOLORSCROLLBAR #x0137) +(define WM_CTLCOLORSTATIC #x0138) +(define MN_GETHMENU #x01E1) + +(define WM_MOUSEFIRST #x0200) +(define WM_MOUSEMOVE #x0200) +(define WM_LBUTTONDOWN #x0201) +(define WM_LBUTTONUP #x0202) +(define WM_LBUTTONDBLCLK #x0203) +(define WM_RBUTTONDOWN #x0204) +(define WM_RBUTTONUP #x0205) +(define WM_RBUTTONDBLCLK #x0206) +(define WM_MBUTTONDOWN #x0207) +(define WM_MBUTTONUP #x0208) +(define WM_MBUTTONDBLCLK #x0209) +(define WM_MOUSEWHEEL #x020A) +(define WM_XBUTTONDOWN #x020B) +(define WM_XBUTTONUP #x020C) +(define WM_XBUTTONDBLCLK #x020D) +(define WM_MOUSELAST #x020D) + +;; Value for rolling one detent +(define WHEEL_DELTA 120) +;; (define WHEEL_PAGESCROLL UINT_MAX) + +;; XButton values are WORD flags +(define XBUTTON1 #x0001) +(define XBUTTON2 #x0002) + +(define WM_PARENTNOTIFY #x0210) +(define WM_ENTERMENULOOP #x0211) +(define WM_EXITMENULOOP #x0212) + +(define WM_NEXTMENU #x0213) +(define WM_SIZING #x0214) +(define WM_CAPTURECHANGED #x0215) +(define WM_MOVING #x0216) + +(define WM_DEVICECHANGE #x0219) + +(define WM_MDICREATE #x0220) +(define WM_MDIDESTROY #x0221) +(define WM_MDIACTIVATE #x0222) +(define WM_MDIRESTORE #x0223) +(define WM_MDINEXT #x0224) +(define WM_MDIMAXIMIZE #x0225) +(define WM_MDITILE #x0226) +(define WM_MDICASCADE #x0227) +(define WM_MDIICONARRANGE #x0228) +(define WM_MDIGETACTIVE #x0229) + + +(define WM_MDISETMENU #x0230) +(define WM_ENTERSIZEMOVE #x0231) +(define WM_EXITSIZEMOVE #x0232) +(define WM_DROPFILES #x0233) +(define WM_MDIREFRESHMENU #x0234) + + +(define WM_IME_SETCONTEXT #x0281) +(define WM_IME_NOTIFY #x0282) +(define WM_IME_CONTROL #x0283) +(define WM_IME_COMPOSITIONFULL #x0284) +(define WM_IME_SELECT #x0285) +(define WM_IME_CHAR #x0286) +(define WM_IME_REQUEST #x0288) +(define WM_IME_KEYDOWN #x0290) +(define WM_IME_KEYUP #x0291) + +(define WM_MOUSEHOVER #x02A1) +(define WM_MOUSELEAVE #x02A3) +(define WM_NCMOUSEHOVER #x02A0) +(define WM_NCMOUSELEAVE #x02A2) + +(define WM_WTSSESSION_CHANGE #x02B1) + +(define WM_TABLET_FIRST #x02c0) +(define WM_TABLET_LAST #x02df) + +(define WM_CUT #x0300) +(define WM_COPY #x0301) +(define WM_PASTE #x0302) +(define WM_CLEAR #x0303) +(define WM_UNDO #x0304) +(define WM_RENDERFORMAT #x0305) +(define WM_RENDERALLFORMATS #x0306) +(define WM_DESTROYCLIPBOARD #x0307) +(define WM_DRAWCLIPBOARD #x0308) +(define WM_PAINTCLIPBOARD #x0309) +(define WM_VSCROLLCLIPBOARD #x030A) +(define WM_SIZECLIPBOARD #x030B) +(define WM_ASKCBFORMATNAME #x030C) +(define WM_CHANGECBCHAIN #x030D) +(define WM_HSCROLLCLIPBOARD #x030E) +(define WM_QUERYNEWPALETTE #x030F) +(define WM_PALETTEISCHANGING #x0310) +(define WM_PALETTECHANGED #x0311) +(define WM_HOTKEY #x0312) + + +;; Class styles +(define CS_VREDRAW #x0001) +(define CS_HREDRAW #x0002) +(define CS_DBLCLKS #x0008) +(define CS_OWNDC #x0020) +(define CS_CLASSDC #x0040) +(define CS_PARENTDC #x0080) +(define CS_NOCLOSE #x0200) +(define CS_SAVEBITS #x0800) +(define CS_BYTEALIGNCLIENT #x1000) +(define CS_BYTEALIGNWINDOW #x2000) +(define CS_GLOBALCLASS #x4000) + +;; Window styles +(define WS_OVERLAPPED #x00000000) +(define WS_POPUP #x80000000) +(define WS_CHILD #x40000000) +(define WS_CLIPSIBLINGS #x04000000) +(define WS_CLIPCHILDREN #x02000000) +(define WS_VISIBLE #x10000000) +(define WS_DISABLED #x08000000) +(define WS_MINIMIZE #x20000000) +(define WS_MAXIMIZE #x01000000) +(define WS_CAPTION #x00C00000) +(define WS_BORDER #x00800000) +(define WS_DLGFRAME #x00400000) +(define WS_VSCROLL #x00200000) +(define WS_HSCROLL #x00100000) +(define WS_SYSMENU #x00080000) +(define WS_THICKFRAME #x00040000) +(define WS_MINIMIZEBOX #x00020000) +(define WS_MAXIMIZEBOX #x00010000) +(define WS_GROUP #x00020000) +(define WS_TABSTOP #x00010000) + +(define WS_OVERLAPPEDWINDOW (bitwise-ior WS_OVERLAPPED WS_CAPTION WS_SYSMENU + WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX)) + +(define PM_NOREMOVE #x0000) +(define PM_REMOVE #x0001) +(define PM_NOYIELD #x0002) + +(define QS_KEY #x0001) +(define QS_MOUSEMOVE #x0002) +(define QS_MOUSEBUTTON #x0004) +(define QS_POSTMESSAGE #x0008) +(define QS_TIMER #x0010) +(define QS_PAINT #x0020) +(define QS_SENDMESSAGE #x0040) +(define QS_HOTKEY #x0080) +(define QS_ALLPOSTMESSAGE #x0100) +(define QS_RAWINPUT #x0400) +(define QS_MOUSE (bitwise-ior QS_MOUSEMOVE + QS_MOUSEBUTTON)) + +(define QS_INPUT (bitwise-ior QS_MOUSE + QS_KEY + QS_RAWINPUT)) +(define QS_ALLEVENTS (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY)) + +(define QS_ALLINPUT (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY + QS_SENDMESSAGE)) + +(define GWLP_WNDPROC -4) +(define GWLP_USERDATA -21) + + +(define COLOR_SCROLLBAR 0) +(define COLOR_BACKGROUND 1) +(define COLOR_ACTIVECAPTION 2) +(define COLOR_INACTIVECAPTION 3) +(define COLOR_MENU 4) +(define COLOR_WINDOW 5) +(define COLOR_WINDOWFRAME 6) +(define COLOR_MENUTEXT 7) +(define COLOR_WINDOWTEXT 8) +(define COLOR_CAPTIONTEXT 9) +(define COLOR_ACTIVEBORDER 10) +(define COLOR_INACTIVEBORDER 11) +(define COLOR_APPWORKSPACE 12) +(define COLOR_HIGHLIGHT 13) +(define COLOR_HIGHLIGHTTEXT 14) +(define COLOR_BTNFACE 15) +(define COLOR_BTNSHADOW 16) +(define COLOR_GRAYTEXT 17) +(define COLOR_BTNTEXT 18) +(define COLOR_INACTIVECAPTIONTEXT 19) +(define COLOR_BTNHIGHLIGHT 20) + +(define BS_PUSHBUTTON #x00000000) +(define BS_DEFPUSHBUTTON #x00000001) +(define BS_CHECKBOX #x00000002) +(define BS_AUTOCHECKBOX #x00000003) +(define BS_RADIOBUTTON #x00000004) +(define BS_3STATE #x00000005) +(define BS_AUTO3STATE #x00000006) +(define BS_GROUPBOX #x00000007) +(define BS_USERBUTTON #x00000008) +(define BS_AUTORADIOBUTTON #x00000009) +(define BS_PUSHBOX #x0000000A) +(define BS_OWNERDRAW #x0000000B) +(define BS_TYPEMASK #x0000000F) +(define BS_LEFTTEXT #x00000020) +(define BS_TEXT #x00000000) +(define BS_ICON #x00000040) +(define BS_BITMAP #x00000080) +(define BS_LEFT #x00000100) +(define BS_RIGHT #x00000200) +(define BS_CENTER #x00000300) +(define BS_TOP #x00000400) +(define BS_BOTTOM #x00000800) +(define BS_VCENTER #x00000C00) +(define BS_PUSHLIKE #x00001000) +(define BS_MULTILINE #x00002000) +(define BS_NOTIFY #x00004000) +(define BS_FLAT #x00008000) +(define BS_RIGHTBUTTON BS_LEFTTEXT) + +(define CW_USEDEFAULT #x80000000) + +(define WS_EX_LAYERED #x00080000) + +(define LWA_ALPHA #x00000002) + +(define MB_OK #x00000000) +(define MB_OKCANCEL #x00000001) +(define MB_ABORTRETRYIGNORE #x00000002) +(define MB_YESNOCANCEL #x00000003) +(define MB_YESNO #x00000004) +(define MB_RETRYCANCEL #x00000005) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index aeb05216..e5351284 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -5,5 +5,7 @@ (provide cursor-driver%) (defclass cursor-driver% object% + (define/public (set-standard c) (void)) + (def/public-unimplemented ok?) (super-new)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 4d9053ad..045517cb 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -1,17 +1,90 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + "../../syntax.rkt" + "../common/queue.rkt" + "utils.ss" + "const.ss" + "types.ss" + "window.rkt" + "wndclass.rkt") (provide frame%) +(define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) + (defclass frame% window% + (init parent + label + x y w h + style) + + (inherit get-win32 + is-shown? + get-eventspace) + + (super-new [parent #f] + [win32 + (CreateWindowExW (bitwise-ior WS_EX_LAYERED) + "PLTFrame" + (if label label "") + WS_OVERLAPPEDWINDOW + 0 0 w h + #f + #f + hInstance + #f)] + [style (cons 'invisible style)]) + + (define win32 (get-win32)) + (SetLayeredWindowAttributes win32 0 255 LWA_ALPHA) + + (define/public (is-dialog?) #f) + + (define/override (show on?) + (let ([es (get-eventspace)]) + (when (and on? + (eventspace-shutdown? es)) + (error (string->symbol + (format "show method in ~a" + (if (is-dialog?) + 'dialog% + 'frame%))) + "eventspace has been shutdown"))) + (super show on?)) + + (define/override (direct-show on?) + (register-frame-shown this on?) + (super direct-show on?)) + + (define/override (wndproc w msg wparam lparam) + (cond + [(= msg WM_CLOSE) + (queue-window-event this (lambda () + (when (on-close) + (direct-show #f)))) + 0] + [else (super wndproc w msg wparam lparam)])) + + (define/public (on-close) (void)) + + (define/override (is-shown-to-root?) + (is-shown?)) + (define/override (is-enabled-to-root?) + #t) + + (define/override (get-x) + (RECT-left (GetWindowRect win32))) + (define/override (get-y) + (RECT-top (GetWindowRect win32))) + (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) (def/public-unimplemented on-menu-command) (def/public-unimplemented on-mdi-activate) - (def/public-unimplemented enforce-size) - (def/public-unimplemented on-close) + + (define/public (enforce-size min-x min-y max-x max-y step-x step-y) + (void)) + (def/public-unimplemented on-activate) (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) @@ -23,5 +96,4 @@ (def/public-unimplemented set-menu-bar) (def/public-unimplemented set-icon) (def/public-unimplemented iconize) - (def/public-unimplemented set-title) - (super-new)) + (def/public-unimplemented set-title)) diff --git a/collects/mred/private/wx/win32/icons.rkt b/collects/mred/private/wx/win32/icons.rkt new file mode 100644 index 00000000..6fd15f99 --- /dev/null +++ b/collects/mred/private/wx/win32/icons.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require ffi/unsafe) + +(provide IDC_ARROW IDC_CROSS + IDI_APPLICATION IDI_HAND IDI_QUESTION IDI_WINLOGO) + +(define (MAKEINTRESOURCE n) (ptr-add #f n)) +(define IDC_ARROW (MAKEINTRESOURCE 32512)) +(define IDC_CROSS (MAKEINTRESOURCE 32515)) +(define IDI_APPLICATION (MAKEINTRESOURCE 32512)) +(define IDI_HAND (MAKEINTRESOURCE 32513)) +(define IDI_QUESTION (MAKEINTRESOURCE 32514)) +(define IDI_WINLOGO (MAKEINTRESOURCE 32517)) diff --git a/collects/mred/private/wx/win32/init.rkt b/collects/mred/private/wx/win32/init.rkt new file mode 100644 index 00000000..f0c23c10 --- /dev/null +++ b/collects/mred/private/wx/win32/init.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +;; Registers the window class: +(require "wndclass.rkt" + "queue.rkt") + +(define pump-thread (win32-start-event-pump)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 69f8d7bf..c069a22e 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -1,16 +1,35 @@ #lang scheme/base (require scheme/class "../../syntax.rkt" - "window.rkt") + "window.rkt" + "wndclass.rkt" + "const.rkt") (provide panel%) (defclass panel% window% + (init parent + x y w h + style + label) + + (super-new [parent parent] + [win32 + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-win32) + #f + hInstance + #f)] + [style style]) + (def/public-unimplemented get-label-position) (def/public-unimplemented set-label-position) (def/public-unimplemented on-char) (def/public-unimplemented on-event) (def/public-unimplemented on-paint) - (def/public-unimplemented set-item-cursor) - (def/public-unimplemented get-item-cursor) - (super-new)) + (define/public (set-item-cursor x y) (void)) + (def/public-unimplemented get-item-cursor)) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 0e8ec5c9..7283e246 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -1,5 +1,6 @@ #lang scheme/base -(require "button.rkt" +(require "init.rkt" + "button.rkt" "canvas.rkt" "check-box.rkt" "choice.rkt" diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 26ba0e07..0a32a352 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -1,5 +1,7 @@ -#lang scheme/base -(require "../../syntax.rkt") +#lang racket/base +(require racket/class + "../../syntax.rkt" + racket/draw) (provide special-control-key @@ -44,25 +46,29 @@ (define-unimplemented special-option-key) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) -(define-unimplemented get-panel-background) +(define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented register-collecting-blit) (define-unimplemented unregister-collecting-blit) -(define-unimplemented shortcut-visible-in-label?) +(define (shortcut-visible-in-label? ?) #t) (define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) (define-unimplemented run-printout) -(define-unimplemented get-double-click-time) -(define-unimplemented get-control-font-size) +(define (get-double-click-time) 500) +(define (get-control-font-size) 10) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) (define-unimplemented flush-display) (define-unimplemented write-resource) (define-unimplemented get-resource) -(define-unimplemented display-origin) -(define-unimplemented display-size) +(define (display-origin xb yb ?) + (set-box! xb 0) + (set-box! yb 0)) +(define (display-size xb yb ?) + (set-box! xb 1024) + (set-box! yb 768)) (define-unimplemented bell) (define-unimplemented hide-cursor) (define-unimplemented end-busy-cursor) @@ -76,8 +82,12 @@ (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define-unimplemented can-show-print-setup?) -(define-unimplemented get-highlight-background-color) -(define-unimplemented get-highlight-text-color) + +(define (get-highlight-background-color) + (make-object color% 0 0 0)) +(define (get-highlight-text-color) + (make-object color% 255 255 255)) + (define-unimplemented make-screen-bitmap) (define (check-for-break) #f) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt new file mode 100644 index 00000000..ca292ea8 --- /dev/null +++ b/collects/mred/private/wx/win32/queue.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "../../lock.rkt" + "../common/queue.rkt") + +(provide win32-start-event-pump + + ;; from common/queue: + current-eventspace + queue-event + yield) + +;; ------------------------------------------------------------ +;; Win32 event pump + +(define _LPMSG _pointer) + +(define-cstruct _MSG ([hwnd _HWND] + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) + +(define-user32 GetQueueStatus (_wfun _UINT -> _DWORD)) +(define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL)) +(define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL)) +(define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL)) +(define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT)) +(define-user32 PostQuitMessage (_wfun _int -> _void)) + +(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void)) + +(define msg (malloc _MSG 'raw)) + +(define (events-ready?) + (GetQueueStatus QS_ALLINPUT)) + +(define (install-wakeup fds) + (pre-event-sync #t) + (scheme_add_fd_eventmask fds QS_ALLINPUT)) + +(set-check-queue! events-ready?) +(set-queue-wakeup! install-wakeup) + +(define (dispatch-all-ready) + (pre-event-sync #f) + (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (dispatch-all-ready)))) + +(define (win32-start-event-pump) + (thread (lambda () + (let loop () + (sync queue-evt) + (as-entry dispatch-all-ready) + (loop))))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt new file mode 100644 index 00000000..4628de51 --- /dev/null +++ b/collects/mred/private/wx/win32/types.rkt @@ -0,0 +1,83 @@ +#lang racket/base +(require ffi/unsafe) + +(provide _wfun + + _DWORD + _ATOM + _WPARAM + _LPARAM + _LRESULT + _BOOL + _UINT + _BYTE + _LONG + + _HINSTANCE + _HWND + _HMENU + _HICON + _HCURSOR + _HBRUSH + _HDC + + _COLORREF + + _fnpointer + + _permanent-string/utf-16 + + (struct-out POINT) _POINT _POINT-pointer + (struct-out RECT) _RECT _RECT-pointer) + +(define-syntax-rule (_wfun . a) + (_fun #:abi 'stdcall . a)) + +(define _DWORD _int32) +(define _ATOM _int) +(define _WPARAM _long) +(define _LPARAM _long) +(define _LRESULT _long) +(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) +(define _UINT _uint) +(define _BYTE _uint8) + +(define _HINSTANCE (_cpointer/null 'HINSTANCE)) +(define _HWND (_cpointer/null 'HWND)) +(define _HMENU (_cpointer/null 'HMENU)) +(define _HICON (_cpointer/null 'HICON)) +(define _HCURSOR (_cpointer/null 'HCURSOR)) +(define _HBRUSH (_cpointer/null 'HBRUSH)) +(define _HDC (_cpointer/null 'HDC)) + +(define _COLORREF _DWORD) + +(define _fnpointer (_or-null _fpointer)) + +(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 (let loop ([i 0]) + (if (zero? (ptr-ref p _uint16 i)) + (add1 i) + (loop (add1 i))))]) + (let ([c (malloc len _uint16 'raw)]) + (memcpy c p len _uint16) + c)))))) + (lambda (p) + (and p + (cast p _pointer _string/utf-16))))) + +(define _LONG _long) + +(define-cstruct _POINT ([x _LONG] + [y _LONG])) + +(define-cstruct _RECT ([left _LONG] + [top _LONG] + [right _LONG] + [bottom _LONG])) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt new file mode 100644 index 00000000..efa9980f --- /dev/null +++ b/collects/mred/private/wx/win32/utils.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "../common/utils.rkt") + +(provide define-user32 + define-kernel32 + define-comctl32 + define-mz) + +(define user32-lib (ffi-lib "user32.dll")) +(define kernel32-lib (ffi-lib "kernel32.dll")) +(define comctl32-lib (ffi-lib "comctl32.dll")) + +(define-ffi-definer define-user32 user32-lib) +(define-ffi-definer define-kernel32 kernel32-lib) +(define-ffi-definer define-comctl32 comctl32-lib) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 30221b71..bd45754d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -1,10 +1,69 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "wndclass.rkt" + "queue.rkt") -(provide window%) +(provide window% + queue-window-event + + CreateWindowExW + GetWindowRect) + +(define-user32 CreateWindowExW (_wfun _DWORD + _string/utf-16 + _string/utf-16 + _DWORD + _int _int _int _int + _HWND _HMENU _HINSTANCE _pointer + -> _HWND)) +(define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) +(define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) + +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL)) + +(define-user32 ShowWindow (_wfun _HWND _int -> _BOOL)) +(define SW_SHOW 5) +(define SW_HIDE 0) + +(define-user32 GetDialogBaseUnits (_fun -> _LONG)) +(define measure-dc #f) + +(define-values (dlu-x dlu-y) + (let ([v (GetDialogBaseUnits)]) + (values (* 1/4 (bitwise-and v #xFF)) + (* 1/8 (arithmetic-shift v -16))))) (defclass window% object% + (init-field parent win32) + (init style) + + (super-new) + + (define eventspace (current-eventspace)) + + (set-win32-wx! win32 this) + + (unless (memq 'invisible style) + (show #t)) + + (define/public (get-win32) win32) + (define/public (get-client-win32) win32) + (define/public (get-eventspace) eventspace) + + (define/public (wndproc w msg wparam lparam) + (DefWindowProcW w msg wparam lparam)) + + (define/public (show on?) + (direct-show on?)) + + (define/public (direct-show on?) + (void (ShowWindow win32 (if on? SW_SHOW SW_HIDE)))) + (def/public-unimplemented on-drop-file) (def/public-unimplemented pre-on-event) (def/public-unimplemented pre-on-char) @@ -12,31 +71,92 @@ (def/public-unimplemented on-set-focus) (def/public-unimplemented on-kill-focus) (def/public-unimplemented get-handle) - (def/public-unimplemented is-enabled-to-root?) - (def/public-unimplemented is-shown-to-root?) + + (define/public (is-window-enabled?) + #t) + + (define/public (is-enabled-to-root?) + (and (is-window-enabled?) + (send parent is-enabled-to-root?))) + + (define/public (is-shown-to-root?) + (and (is-shown?) + (send parent is-shown-to-root?))) + + (define/public (is-shown?) + #t) + (def/public-unimplemented set-phantom-size) - (def/public-unimplemented get-y) - (def/public-unimplemented get-x) - (def/public-unimplemented get-width) - (def/public-unimplemented get-height) + + (define/public (get-x) + (let ([r (GetWindowRect win32)]) + (- (RECT-left r) (send parent get-x)))) + (define/public (get-y) + (let ([r (GetWindowRect win32)]) + (- (RECT-top r) (send parent get-y)))) + + (define/public (get-width) + (let ([r (GetWindowRect win32)]) + (- (RECT-right r) (RECT-left r)))) + (define/public (get-height) + (let ([r (GetWindowRect win32)]) + (- (RECT-bottom r) (RECT-top r)))) + + (define/public (set-size x y w h) + (void + (if (or (= x -11111) + (= y -11111) + (= w -1) + (= h -1)) + (let ([r (GetWindowRect win32)]) + (MoveWindow win32 + (if (= x -11111) (RECT-left r) x) + (if (= y -11111) (RECT-right r) y) + (if (= w -1) (- (RECT-right r) (RECT-left r)) w) + (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) + #t)) + (MoveWindow win32 x y w h #t)))) + (define/public (move x y) + (set-size x y -1 -1)) + + (define/public (auto-size label min-w min-h) + (unless measure-dc + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)] + [font (make-object font% 8 'system)]) + (send dc set-font font) + (set! measure-dc dc))) + (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)] + [(->int) (lambda (v) (inexact->exact (floor v)))]) + (set-size -11111 -11111 + (max (->int w) (->int (* dlu-x min-w))) + (max (->int h) (->int (* dlu-y min-h)))))) + (def/public-unimplemented popup-menu) (def/public-unimplemented center) - (def/public-unimplemented get-parent) + + (define/public (get-parent) parent) + (def/public-unimplemented refresh) (def/public-unimplemented screen-to-client) (def/public-unimplemented client-to-screen) (def/public-unimplemented drag-accept-files) (def/public-unimplemented enable) (def/public-unimplemented get-position) - (def/public-unimplemented get-client-size) + + (define/public (get-client-size w h) + (let ([r (GetClientRect (get-client-win32))]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (def/public-unimplemented get-size) (def/public-unimplemented fit) - (def/public-unimplemented is-shown?) - (def/public-unimplemented show) (def/public-unimplemented set-cursor) - (def/public-unimplemented move) - (def/public-unimplemented set-size) (def/public-unimplemented set-focus) (def/public-unimplemented gets-focus?) - (def/public-unimplemented centre) - (super-new)) + (def/public-unimplemented centre)) + +;; ---------------------------------------- + +(define (queue-window-event win thunk) + (queue-event (send win get-eventspace) thunk)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt new file mode 100644 index 00000000..1fd6c539 --- /dev/null +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -0,0 +1,112 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "const.rkt" + "icons.rkt") + +(provide hInstance + DefWindowProcW + win32->wx + set-win32-wx! + MessageBoxW) + +;; ---------------------------------------- + +(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) +(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) + +(define (win32->wx win32) + (let ([p (GetWindowLongW win32 GWLP_USERDATA)]) + (and p (ptr-ref p _racket)))) + +(define (set-win32-wx! win32 wx) + (SetWindowLongW win32 GWLP_USERDATA (malloc-immobile-cell wx))) + +;; ---------------------------------------- + +(define-cstruct _INITCOMMONCONTROLSEX + ([dwSize _DWORD] + [dwICC _DWORD])) + +(define-comctl32 InitCommonControlsEx (_wfun _INITCOMMONCONTROLSEX-pointer -> _BOOL)) + +(void + (InitCommonControlsEx (make-INITCOMMONCONTROLSEX + (ctype-sizeof _INITCOMMONCONTROLSEX) + 0))) + +;; ---------------------------------------- + +(define _WndProc (_wfun #:atomic? #t #:keep (box null) + _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + +(define-cstruct _WNDCLASS ([style _UINT] + [lpfnWndProc _WndProc] + [cbClsExtra _int] + [cbWndExtra _int] + [hInstace _HINSTANCE] + [hIcon _HICON] + [hCursor _HCURSOR] + [hbrBackground _HBRUSH] + [lpszMenuName _permanent-string/utf-16] + [lpszClassName _permanent-string/utf-16])) + +(define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM)) +(define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE)) +(define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR)) +(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON)) + +(define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + +#;(define-user32 PostQuitMessage (_wfun _int -> _void)) + +(define (wind-proc w msg wparam lparam) + (let ([wx (win32->wx w)]) + (if wx + (send wx wndproc w msg wparam lparam) + (DefWindowProcW w msg wparam lparam)))) + +(define hInstance (GetModuleHandleW #f)) + +(void (RegisterClassW (make-WNDCLASS CS_OWNDC + wind-proc + 0 + 0 + hInstance + (LoadIconW #f IDI_APPLICATION) + (LoadCursorW #f IDC_ARROW) + (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p) + #f ; menu + "PLTFrame"))) + +(void (RegisterClassW (make-WNDCLASS 0 ; not CS_OWNDC ! + wind-proc + 0 + 0 + hInstance + #f + (LoadCursorW #f IDC_ARROW) + (let ([p (ptr-add #f (+ COLOR_WINDOW 1))]) + (cpointer-push-tag! p 'HBRUSH) + p) + #f ; menu + "PLTCanvas"))) + +(void (RegisterClassW (make-WNDCLASS 0 + wind-proc + 0 + 0 + hInstance + #f + (LoadCursorW #f IDC_ARROW) + (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p) + #f ; menu + "PLTPanel"))) + +(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int)) From 80e2b57c53dffadbc71d33d93b598a1cd20932ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Sep 2010 10:29:36 -0600 Subject: [PATCH 240/462] win32 theme and basic canvas original commit: 35703b49b9ef7bb534767b6c33b7f554a425a83e --- collects/mred/private/wx/gtk/dc.rkt | 2 +- collects/mred/private/wx/platform.rkt | 2 +- collects/mred/private/wx/win32/button.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 158 ++++++++++++++++++---- collects/mred/private/wx/win32/dc.rkt | 114 ++++++++++++++++ collects/mred/private/wx/win32/procs.rkt | 3 +- collects/mred/private/wx/win32/queue.rkt | 3 +- collects/mred/private/wx/win32/theme.rkt | 78 +++++++++++ collects/mred/private/wx/win32/types.rkt | 4 + collects/mred/private/wx/win32/utils.rkt | 8 +- collects/mred/private/wx/win32/window.rkt | 32 ++++- 11 files changed, 365 insertions(+), 41 deletions(-) create mode 100644 collects/mred/private/wx/win32/dc.rkt create mode 100644 collects/mred/private/wx/win32/theme.rkt diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 5b223022..8265735c 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -54,7 +54,7 @@ (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if gdk-win + (if (not gdk-win) (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) (atomically (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))]) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 2507a56f..222204a2 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -4,7 +4,7 @@ (define-runtime-path platform-lib (case (system-type) - [() '(lib "mred/private/wx/win32/platform.rkt")] + [(#;windows) '(lib "mred/private/wx/win32/platform.rkt")] [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] [(windows unix) '(lib "mred/private/wx/gtk/platform.rkt")])) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 478b6af4..972bc468 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -27,6 +27,6 @@ #f)] [style style]) - (auto-size label 50 14) + (auto-size label 40 12 12 0) (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 78456edb..dd34e487 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -1,32 +1,132 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + racket/draw + "../../syntax.rkt" + "../../lock.rkt" + "../common/canvas-mixin.rkt" + "../common/backing-dc.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "window.rkt" + "dc.rkt") (provide canvas%) -(defclass canvas% window% - (def/public-unimplemented get-canvas-background) - (def/public-unimplemented set-canvas-background) - (def/public-unimplemented set-background-to-gray) - (def/public-unimplemented on-scroll) - (def/public-unimplemented set-scroll-page) - (def/public-unimplemented set-scroll-range) - (def/public-unimplemented set-scroll-pos) - (def/public-unimplemented get-scroll-page) - (def/public-unimplemented get-scroll-range) - (def/public-unimplemented get-scroll-pos) - (def/public-unimplemented scroll) - (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) - (def/public-unimplemented set-resize-corner) - (def/public-unimplemented show-scrollbars) - (def/public-unimplemented set-scrollbars) - (def/public-unimplemented get-virtual-size) - (def/public-unimplemented get-dc) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event) - (def/public-unimplemented on-paint) - (def/public-unimplemented begin-refresh-sequence) - (def/public-unimplemented end-refresh-sequence) - (super-new)) +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) +(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL)) + +(define canvas% + (canvas-mixin + (class window% + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-win32 + get-client-size) + + (define hscroll? (memq 'hscroll style)) + (define vscroll? (memq 'vscroll style)) + + (super-new [parent parent] + [win32 + (CreateWindowExW 0 + "PLTCanvas" + #f + (bitwise-ior WS_CHILD WS_VISIBLE + (if hscroll? WS_HSCROLL 0) + (if vscroll? WS_VSCROLL 0)) + 0 0 w h + (send parent get-win32) + #f + hInstance + #f)] + [style style]) + + (define win32 (get-win32)) + + (define/override (wndproc w msg wparam lparam) + (cond + [(= msg WM_PAINT) + (let* ([ps (malloc 128)] + [hdc (BeginPaint w ps)]) + (unless (positive? paint-suspended) + (unless (do-backing-flush this dc hdc) + (queue-paint)) + (do-backing-flush this dc hdc)) + (EndPaint hdc ps)) + 0] + [else (super wndproc w msg wparam lparam)])) + + (define dc (new dc% [canvas this])) + + (define/public (get-dc) dc) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay this)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (get-flush-window) win32) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + (define/public (on-paint) (void)) + (define/override (refresh) (queue-paint)) + + (define/public (queue-backing-flush) + (void (InvalidateRect win32 #f #t))) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define paint-suspended 0) + (define/public (suspend-paint-handling) + (atomically + (set! paint-suspended (add1 paint-suspended)))) + (define/public (resume-paint-handling) + (atomically + (unless (zero? paint-suspended) + (set! paint-suspended (sub1 paint-suspended))))) + + (define/public (get-virtual-size w h) + (get-client-size w h)) + + (define transparent? (memq 'transparent style)) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + + (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented on-scroll) + (def/public-unimplemented set-scroll-page) + (def/public-unimplemented set-scroll-range) + (def/public-unimplemented set-scroll-pos) + (def/public-unimplemented get-scroll-page) + (def/public-unimplemented get-scroll-range) + (def/public-unimplemented get-scroll-pos) + (def/public-unimplemented scroll) + (def/public-unimplemented warp-pointer) + (def/public-unimplemented view-start) + (def/public-unimplemented set-resize-corner) + (def/public-unimplemented show-scrollbars) + (def/public-unimplemented set-scrollbars) + (def/public-unimplemented on-char) + (def/public-unimplemented on-event)))) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt new file mode 100644 index 00000000..ab997110 --- /dev/null +++ b/collects/mred/private/wx/win32/dc.rkt @@ -0,0 +1,114 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "../../lock.rkt" + "../common/backing-dc.rkt" + "../common/delay.rkt" + racket/draw/cairo + racket/draw/dc + racket/draw/bitmap + racket/draw/local + ffi/unsafe/alloc) + +(provide dc% + do-backing-flush + request-flush-delay + cancel-flush-delay) + +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 ReleaseDC (_wfun _HDC -> _void)) + +(define win32-bitmap% + (class bitmap% + (init w h win32) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define s + (if (not win32) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC win32)]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hdc)))))) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (inherit end-delay) + (define canvas cnvs) + + (super-new) + + (define/override (make-backing-bitmap w h) + (if (send canvas get-canvas-background) + (make-object win32-bitmap% w h (send canvas get-win32)) + (super make-backing-bitmap w h))) + + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) + (send canvas queue-backing-flush)) + + (define/override (request-delay) + (request-flush-delay canvas)) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) + +(define (do-backing-flush canvas dc hdc) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let* ([surface (cairo_win32_surface_create hdc)] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + +(define (request-flush-delay canvas) + (do-request-flush-delay + canvas + (lambda (gtk) + (send canvas suspend-paint-handling)) + (lambda (gtk) + (send canvas resume-paint-handling)))) + +(define (cancel-flush-delay req) + (when req + (do-cancel-flush-delay + req + (lambda (canvas) + (send canvas resume-paint-handling))))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 0a32a352..5e785901 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class "../../syntax.rkt" + "theme.rkt" racket/draw) (provide @@ -57,7 +58,7 @@ (define-unimplemented file-creator-and-type) (define-unimplemented run-printout) (define (get-double-click-time) 500) -(define (get-control-font-size) 10) +(define (get-control-font-size) (get-theme-font-size)) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) (define-unimplemented flush-display) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index ca292ea8..229c6aff 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -11,6 +11,7 @@ ;; from common/queue: current-eventspace queue-event + queue-refresh-event yield) ;; ------------------------------------------------------------ @@ -37,7 +38,7 @@ (define msg (malloc _MSG 'raw)) (define (events-ready?) - (GetQueueStatus QS_ALLINPUT)) + (not (zero? (GetQueueStatus QS_ALLINPUT)))) (define (install-wakeup fds) (pre-event-sync #t) diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt new file mode 100644 index 00000000..70b6f79f --- /dev/null +++ b/collects/mred/private/wx/win32/theme.rkt @@ -0,0 +1,78 @@ +#lang racket/base +(require ffi/unsafe + "utils.ss" + "const.ss" + "types.ss") + +(provide get-theme-logfont + get-theme-font-face + get-theme-font-size + _LOGFONT-pointer) + +(define _HTHEME (_cpointer 'HTHEME)) + +(define-cstruct _FaceName1 + ([c1 _uint16] + [c2 _uint16] + [c3 _uint16] + [c4 _uint16] + [c5 _uint16] + [c6 _uint16] + [c7 _uint16] + [c8 _uint16])) + +(define-cstruct _FaceName + ([f1 _FaceName1] + [f2 _FaceName1] + [f3 _FaceName1] + [f4 _FaceName1])) + +(define-cstruct _LOGFONT + ([lfHeight _LONG] + [lfWidth _LONG] + [lfEscapement _LONG] + [lfOrientation _LONG] + [lfWeight _LONG] + [lfItalic _BYTE] + [lfUnderline _BYTE] + [lfStrikeOut _BYTE] + [lfCharSet _BYTE] + [lfOutPrecision _BYTE] + [lfClipPrecision _BYTE] + [lfQuality _BYTE] + [lfPitchAndFamily _BYTE] + [lfFaceName _FaceName])) ; 32 of them + +(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)) +(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT) + -> (when (negative? r) + (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))) +(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define BP_PUSHBUTTON 1) +(define PBS_NORMAL 1) +(define TMT_FONT 210) +(define TMT_BODYFONT 809) + +(define TMT_MSGBOXFONT 805) + +(define theme-logfont (GetThemeSysFont #f TMT_MSGBOXFONT)) + +(define (get-theme-logfont) + theme-logfont) + +(define (get-theme-font-face) + (cast (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16)) + +(define (get-theme-font-size) + (abs (LOGFONT-lfHeight theme-logfont))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 4628de51..3f19d936 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -12,6 +12,7 @@ _UINT _BYTE _LONG + _HRESULT _HINSTANCE _HWND @@ -20,6 +21,7 @@ _HCURSOR _HBRUSH _HDC + _HFONT _COLORREF @@ -41,6 +43,7 @@ (define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) (define _UINT _uint) (define _BYTE _uint8) +(define _HRESULT _int32) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -49,6 +52,7 @@ (define _HCURSOR (_cpointer/null 'HCURSOR)) (define _HBRUSH (_cpointer/null 'HBRUSH)) (define _HDC (_cpointer/null 'HDC)) +(define _HFONT (_cpointer/null 'HFONT)) (define _COLORREF _DWORD) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index efa9980f..074f2068 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -3,15 +3,21 @@ ffi/unsafe/define "../common/utils.rkt") -(provide define-user32 +(provide define-gdi32 + define-user32 define-kernel32 define-comctl32 + define-uxtheme define-mz) +(define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define uxtheme-lib (ffi-lib "uxtheme.dll")) +(define-ffi-definer define-gdi32 gdi32-lib) (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-uxtheme uxtheme-lib) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index bd45754d..aa97a4cb 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -5,11 +5,14 @@ "../../syntax.rkt" "utils.rkt" "types.rkt" + "const.rkt" "wndclass.rkt" - "queue.rkt") + "queue.rkt" + "theme.rkt") (provide window% queue-window-event + queue-window-refresh-event CreateWindowExW GetWindowRect) @@ -24,6 +27,10 @@ (define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) (define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) +(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) + +(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL)) (define-user32 ShowWindow (_wfun _HWND _int -> _BOOL)) @@ -33,9 +40,11 @@ (define-user32 GetDialogBaseUnits (_fun -> _LONG)) (define measure-dc #f) +(define theme-hfont #f) + (define-values (dlu-x dlu-y) (let ([v (GetDialogBaseUnits)]) - (values (* 1/4 (bitwise-and v #xFF)) + (values (* 1/4 (bitwise-and v #xFFFF)) (* 1/8 (arithmetic-shift v -16))))) (defclass window% object% @@ -88,6 +97,8 @@ (def/public-unimplemented set-phantom-size) + (define/public (paint-children) (void)) + (define/public (get-x) (let ([r (GetWindowRect win32)]) (- (RECT-left r) (send parent get-x)))) @@ -119,7 +130,10 @@ (define/public (move x y) (set-size x y -1 -1)) - (define/public (auto-size label min-w min-h) + (define/public (auto-size label min-w min-h dw dh) + (unless theme-hfont + (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) + (SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -129,8 +143,8 @@ (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)] [(->int) (lambda (v) (inexact->exact (floor v)))]) (set-size -11111 -11111 - (max (->int w) (->int (* dlu-x min-w))) - (max (->int h) (->int (* dlu-y min-h)))))) + (max (->int (+ w dw)) (->int (* dlu-x min-w))) + (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) (def/public-unimplemented popup-menu) (def/public-unimplemented center) @@ -140,7 +154,10 @@ (def/public-unimplemented refresh) (def/public-unimplemented screen-to-client) (def/public-unimplemented client-to-screen) - (def/public-unimplemented drag-accept-files) + + (define/public (drag-accept-files on?) + (void)) + (def/public-unimplemented enable) (def/public-unimplemented get-position) @@ -160,3 +177,6 @@ (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) + +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk)) From bc8b9d562f3a5b8d4d36788a86aec943a47bdc8c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Sep 2010 06:00:58 -0600 Subject: [PATCH 241/462] win32 basic canvas, key handling, and eventspaces original commit: ee30013098c51c0b5cc75ac3ca2bf7058cf6dc63 --- collects/mred/private/wx/common/queue.rkt | 7 +- collects/mred/private/wx/win32/button.rkt | 4 +- collects/mred/private/wx/win32/canvas.rkt | 121 ++++++++-- collects/mred/private/wx/win32/const.rkt | 139 +++++++++++ collects/mred/private/wx/win32/dc.rkt | 10 +- collects/mred/private/wx/win32/frame.rkt | 85 ++++++- collects/mred/private/wx/win32/key.rkt | 230 +++++++++++++++++++ collects/mred/private/wx/win32/menu-bar.rkt | 2 +- collects/mred/private/wx/win32/menu-item.rkt | 2 +- collects/mred/private/wx/win32/menu.rkt | 14 +- collects/mred/private/wx/win32/panel.rkt | 6 +- collects/mred/private/wx/win32/procs.rkt | 6 +- collects/mred/private/wx/win32/queue.rkt | 114 +++++++-- collects/mred/private/wx/win32/types.rkt | 23 +- collects/mred/private/wx/win32/utils.rkt | 13 +- collects/mred/private/wx/win32/window.rkt | 217 +++++++++++++---- collects/mred/private/wx/win32/wndclass.rkt | 30 ++- 17 files changed, 900 insertions(+), 123 deletions(-) create mode 100644 collects/mred/private/wx/win32/key.rkt diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e7bc3052..5a26a8d5 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -30,6 +30,7 @@ main-eventspace? eventspace-handler-thread eventspace-wait-cursor-count + eventspace-extra-table queue-callback middle-queue-key @@ -151,7 +152,8 @@ done-evt [shutdown? #:mutable] done-sema - [wait-cursor-count #:mutable]) + [wait-cursor-count #:mutable] + extra-table) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -315,7 +317,8 @@ (semaphore-peek-evt done-sema) #f done-sema - 0)] + 0 + (make-hash))] [cb-box (box #f)]) (parameterize ([current-cb-box cb-box]) (scheme_add_managed (current-custodian) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 972bc468..df623434 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -15,13 +15,13 @@ (init parent cb label x y w h style font) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "BUTTON" label (bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS) 0 0 0 0 - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index dd34e487..4fbd9bbc 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -18,7 +18,29 @@ (define-user32 GetDC (_wfun _HWND -> _HDC)) (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) -(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL)) +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) + -> (unless r (failed 'InvalidateRect)))) +(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'ShowScrollbar)))) + +(define-cstruct _SCROLLINFO + ([cbSize _UINT] + [fMask _UINT] + [nMin _int] + [nMax _int] + [nPage _UINT] + [nPos _int] + [nTrackPos _int])) + +(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int)) +(define-user32 GetScrollPos (_wfun _HWND _int -> _int)) +(define-user32 SetScrollPos (_wfun _HWND _int _BOOL -> _int)) +(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer + = (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior SIF_RANGE SIF_POS SIF_PAGE) + 0 0 0 0 0)) + -> (r : _BOOL) + -> (if r i (error 'GetScrollInfo "failed")))) (define canvas% (canvas-mixin @@ -29,14 +51,14 @@ [ignored-name #f] [gl-config #f]) - (inherit get-win32 + (inherit get-hwnd get-client-size) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "PLTCanvas" #f @@ -44,13 +66,13 @@ (if hscroll? WS_HSCROLL 0) (if vscroll? WS_VSCROLL 0)) 0 0 w h - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] [style style]) - (define win32 (get-win32)) + (define hwnd (get-hwnd)) (define/override (wndproc w msg wparam lparam) (cond @@ -66,9 +88,13 @@ [else (super wndproc w msg wparam lparam)])) (define dc (new dc% [canvas this])) + (send dc start-backing-retained) (define/public (get-dc) dc) + (define/override (on-resized) + (send dc reset-backing-retained)) + ;; The `queue-paint' and `paint-children' methods ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) @@ -79,7 +105,7 @@ (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) - (define/public (get-flush-window) win32) + (define/public (get-flush-window) hwnd) (define/public (begin-refresh-sequence) (send dc suspend-flush)) @@ -90,7 +116,7 @@ (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) - (void (InvalidateRect win32 #f #t))) + (InvalidateRect hwnd #f #t)) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) @@ -114,19 +140,78 @@ bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) + (define h-scroll-visible? hscroll?) + (define v-scroll-visible? vscroll?) + (define/public (show-scrollbars h? v?) + (when hscroll? + (atomically + (set! h-scroll-visible? (and h? #t)) + (ShowScrollBar hwnd SB_HORZ h?))) + (when vscroll? + (atomically + (set! v-scroll-visible? (and v? #t)) + (ShowScrollBar hwnd SB_VERT v?)))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (define (make-info len page pos vis?) + (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) + SIF_RANGE + SIF_POS + SIF_PAGE) + 0 (+ len page -1) page pos 0)) + (when hscroll? + (SetScrollInfo hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) + (when vscroll? + (SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) + (def/public-unimplemented set-background-to-gray) (def/public-unimplemented on-scroll) - (def/public-unimplemented set-scroll-page) - (def/public-unimplemented set-scroll-range) - (def/public-unimplemented set-scroll-pos) - (def/public-unimplemented get-scroll-page) - (def/public-unimplemented get-scroll-range) - (def/public-unimplemented get-scroll-pos) + + (define/public (get-scroll-pos which) + (GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) + (define/public (get-scroll-range which) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (+ (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i) + 1))) + (define/public (get-scroll-page which) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (SCROLLINFO-nPage i))) + + (define/public (set-scroll-pos which v) + (void (SetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) + (define/public (set-scroll-range which v) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (- v (SCROLLINFO-nPage i) -1)) + (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (define/public (set-scroll-page which v) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (- (+ (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) + v)) + (set-SCROLLINFO-nPage! i v) + (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + + (define/override (definitely-wants-event? e) + #t) + (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) (def/public-unimplemented view-start) - (def/public-unimplemented set-resize-corner) - (def/public-unimplemented show-scrollbars) - (def/public-unimplemented set-scrollbars) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event)))) + (def/public-unimplemented set-resize-corner)))) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index b3cbc40f..8eddac09 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -411,3 +411,142 @@ (define MB_YESNOCANCEL #x00000003) (define MB_YESNO #x00000004) (define MB_RETRYCANCEL #x00000005) + +(define SIZE_RESTORED 0) +(define SIZE_MINIMIZED 1) +(define SIZE_MAXIMIZED 2) +(define SIZE_MAXSHOW 3) +(define SIZE_MAXHIDE 4) + +(define SB_HORZ 0) +(define SB_VERT 1) +(define SB_CTL 2) +(define SB_BOTH 3) + +(define SIF_RANGE #x0001) +(define SIF_PAGE #x0002) +(define SIF_POS #x0004) +(define SIF_DISABLENOSCROLL #x0008) +(define SIF_TRACKPOS #x0010) +(define SIF_ALL (bitwise-ior SIF_RANGE SIF_PAGE SIF_POS SIF_TRACKPOS)) + +(define VK_LBUTTON #x01) +(define VK_RBUTTON #x02) +(define VK_CANCEL #x03) +(define VK_MBUTTON #x04) +(define VK_XBUTTON1 #x05) +(define VK_XBUTTON2 #x06) +(define VK_BACK #x08) +(define VK_TAB #x09) +(define VK_CLEAR #x0C) +(define VK_RETURN #x0D) +(define VK_SHIFT #x10) +(define VK_CONTROL #x11) +(define VK_MENU #x12) +(define VK_PAUSE #x13) +(define VK_CAPITAL #x14) +(define VK_KANA #x15) +(define VK_HANGUL #x15) +(define VK_JUNJA #x17) +(define VK_FINAL #x18) +(define VK_HANJA #x19) +(define VK_KANJI #x19) +(define VK_ESCAPE #x1B) +(define VK_CONVERT #x1C) +(define VK_NONCONVERT #x1D) +(define VK_ACCEPT #x1E) +(define VK_MODECHANGE #x1F) +(define VK_SPACE #x20) +(define VK_PRIOR #x21) +(define VK_NEXT #x22) +(define VK_END #x23) +(define VK_HOME #x24) +(define VK_LEFT #x25) +(define VK_UP #x26) +(define VK_RIGHT #x27) +(define VK_DOWN #x28) +(define VK_SELECT #x29) +(define VK_PRINT #x2A) +(define VK_EXECUTE #x2B) +(define VK_SNAPSHOT #x2C) +(define VK_INSERT #x2D) +(define VK_DELETE #x2E) +(define VK_HELP #x2F) +(define VK_LWIN #x5B) +(define VK_RWIN #x5C) +(define VK_APPS #x5D) +(define VK_SLEEP #x5F) +(define VK_NUMPAD0 #x60) +(define VK_NUMPAD1 #x61) +(define VK_NUMPAD2 #x62) +(define VK_NUMPAD3 #x63) +(define VK_NUMPAD4 #x64) +(define VK_NUMPAD5 #x65) +(define VK_NUMPAD6 #x66) +(define VK_NUMPAD7 #x67) +(define VK_NUMPAD8 #x68) +(define VK_NUMPAD9 #x69) +(define VK_MULTIPLY #x6A) +(define VK_ADD #x6B) +(define VK_SEPARATOR #x6C) +(define VK_SUBTRACT #x6D) +(define VK_DECIMAL #x6E) +(define VK_DIVIDE #x6F) +(define VK_F1 #x70) +(define VK_F2 #x71) +(define VK_F3 #x72) +(define VK_F4 #x73) +(define VK_F5 #x74) +(define VK_F6 #x75) +(define VK_F7 #x76) +(define VK_F8 #x77) +(define VK_F9 #x78) +(define VK_F10 #x79) +(define VK_F11 #x7A) +(define VK_F12 #x7B) +(define VK_F13 #x7C) +(define VK_F14 #x7D) +(define VK_F15 #x7E) +(define VK_F16 #x7F) +(define VK_F17 #x80) +(define VK_F18 #x81) +(define VK_F19 #x82) +(define VK_F20 #x83) +(define VK_F21 #x84) +(define VK_F22 #x85) +(define VK_F23 #x86) +(define VK_F24 #x87) +(define VK_NUMLOCK #x90) +(define VK_SCROLL #x91) +(define VK_LSHIFT #xA0) +(define VK_RSHIFT #xA1) +(define VK_LCONTROL #xA2) +(define VK_RCONTROL #xA3) +(define VK_LMENU #xA4) +(define VK_RMENU #xA5) +(define VK_OEM_1 #xBA) +(define VK_OEM_PLUS #xBB) +(define VK_OEM_COMMA #xBC) +(define VK_OEM_MINUS #xBD) +(define VK_OEM_PERIOD #xBE) +(define VK_OEM_2 #xBF) +(define VK_OEM_3 #xC0) +(define VK_OEM_4 #xDB) +(define VK_OEM_5 #xDC) +(define VK_OEM_6 #xDD) +(define VK_OEM_7 #xDE) +(define VK_OEM_8 #xDF) + +(define KF_EXTENDED #x0100) +(define KF_DLGMODE #x0800) +(define KF_MENUMODE #x1000) +(define KF_ALTDOWN #x2000) +(define KF_REPEAT #x4000) +(define KF_UP #x8000) + +(define GW_HWNDFIRST 0) +(define GW_HWNDLAST 1) +(define GW_HWNDNEXT 2) +(define GW_HWNDPREV 3) +(define GW_OWNER 4) +(define GW_CHILD 5) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index ab997110..37375244 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -18,18 +18,18 @@ cancel-flush-delay) (define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HDC -> _void)) +(define-user32 ReleaseDC (_wfun _HDC -> _int)) (define win32-bitmap% (class bitmap% - (init w h win32) + (init w h hwnd) (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if (not win32) + (if (not hwnd) (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) (atomically - (let ([hdc (GetDC win32)]) + (let ([hdc (GetDC hwnd)]) (begin0 (cairo_win32_surface_create_with_ddb hdc CAIRO_FORMAT_RGB24 w h) @@ -56,7 +56,7 @@ (define/override (make-backing-bitmap w h) (if (send canvas get-canvas-background) - (make-object win32-bitmap% w h (send canvas get-win32)) + (make-object win32-bitmap% w h (send canvas get-hwnd)) (super make-backing-bitmap w h))) (define/override (get-backing-size xb yb) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 045517cb..b2c47468 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -1,5 +1,7 @@ #lang racket/base (require racket/class + (only-in racket/list last) + ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" "utils.ss" @@ -11,6 +13,8 @@ (provide frame%) (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) +(define-user32 GetActiveWindow (_wfun -> _HWND)) +(define-user32 SetFocus (_wfun _HWND -> _HWND)) (defclass frame% window% (init parent @@ -18,13 +22,15 @@ x y w h style) - (inherit get-win32 + (inherit get-hwnd is-shown? - get-eventspace) + get-eventspace + on-size + pre-on-char pre-on-event) (super-new [parent #f] - [win32 - (CreateWindowExW (bitwise-ior WS_EX_LAYERED) + [hwnd + (CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED) "PLTFrame" (if label label "") WS_OVERLAPPEDWINDOW @@ -35,8 +41,8 @@ #f)] [style (cons 'invisible style)]) - (define win32 (get-win32)) - (SetLayeredWindowAttributes win32 0 255 LWA_ALPHA) + (define hwnd (get-hwnd)) + (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) (define/public (is-dialog?) #f) @@ -56,14 +62,33 @@ (register-frame-shown this on?) (super direct-show on?)) - (define/override (wndproc w msg wparam lparam) + (define/private (stdret f d) + (if (is-dialog?) d f)) + + (define/override (wndproc w msg wParam lParam) (cond [(= msg WM_CLOSE) (queue-window-event this (lambda () (when (on-close) (direct-show #f)))) 0] - [else (super wndproc w msg wparam lparam)])) + [(= msg WM_SIZE) + (unless (= wParam SIZE_MINIMIZED) + (queue-window-event this (lambda () (on-size 0 0)))) + (stdret 0 1)] + [(= msg WM_MOVE) + (queue-window-event this (lambda () (on-size 0 0))) + 0] + [(= msg WM_ACTIVATE) + (let ([state (LOWORD wParam)] + [minimized (HIWORD wParam)]) + (unless (not (zero? minimized)) + (let ([on? (or (= state WA_ACTIVE) + (= state WA_CLICKACTIVE))]) + (when on? (set-frame-focus)) + (queue-window-event this (lambda () (on-activate on?)))))) + 0] + [else (super wndproc w msg wParam lParam)])) (define/public (on-close) (void)) @@ -73,9 +98,9 @@ #t) (define/override (get-x) - (RECT-left (GetWindowRect win32))) + (RECT-left (GetWindowRect hwnd))) (define/override (get-y) - (RECT-top (GetWindowRect win32))) + (RECT-top (GetWindowRect hwnd))) (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) @@ -85,7 +110,41 @@ (define/public (enforce-size min-x min-y max-x max-y step-x step-y) (void)) - (def/public-unimplemented on-activate) + (define focus-window-path #f) + (define/override (not-focus-child v) + (when (and focus-window-path + (memq v focus-window-path)) + (set! focus-window-path #f))) + (define/override (set-top-focus win win-path child-hwnd) + (set! focus-window-path win-path) + (when (ptr-equal? hwnd (GetActiveWindow)) + (SetFocus child-hwnd))) + + (define/private (set-frame-focus) + (when focus-window-path + (SetFocus (send (last focus-window-path) get-hwnd)))) + + (define/override (child-can-accept-focus?) + #t) + + (define/public (on-activate on?) (void)) + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define dialog-level 0) + (define/public (frame-relative-dialog-status win) + (cond + [(is-dialog?) (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))] + [else #f])) + + (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) @@ -93,7 +152,9 @@ (def/public-unimplemented maximize) (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) - (def/public-unimplemented set-menu-bar) + + (define/public (set-menu-bar mb) (void)) + (def/public-unimplemented set-icon) (def/public-unimplemented iconize) (def/public-unimplemented set-title)) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt new file mode 100644 index 00000000..b56ecdf0 --- /dev/null +++ b/collects/mred/private/wx/win32/key.rkt @@ -0,0 +1,230 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "../common/event.rkt") + +(provide make-key-event + generates-key-event?) + +(define-user32 GetKeyState (_wfun _int -> _SHORT)) +(define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) +(define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT)) + +(define (generates-key-event? msg) + (let ([message (MSG-message msg)]) + (and (memq message (list WM_KEYDOWN WM_SYSKEYDOWN + WM_KEYUP WM_SYSKEYUP)) + (make-key-event #t + (MSG-wParam msg) + (MSG-lParam msg) + #f + (or (= message WM_KEYUP) + (= message WM_SYSKEYUP)) + (MSG-hwnd msg))))) + +(define (THE_SCAN_CODE lParam) + (bitwise-and (arithmetic-shift lParam -16) #x1FF)) + +(define generic_ascii_code (make-hasheq)) + +;; The characters in find_shift_alts are things that we'll try +;; to include in keyboard events as char-if-Shift-weren't-pressed, +;; char-if-AltGr-weren't-pressed, etc. +(define other-key-codes + (let ([find_shift_alts (string-append + "!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789")]) + (list->vector + (for/list ([i (in-string find_shift_alts)]) + (VkKeyScanW (char->integer i)))))) + +;; If a virtual key code has no mapping here, then the key should be +;; ignored by WM_KEYDOWN and processed by WM_CHAR instead +(define win32->symbol + (hasheq VK_CANCEL 'cancel + VK_BACK 'back + VK_TAB 'tab + VK_CLEAR 'clear + VK_RETURN 'return + VK_SHIFT 'shift + VK_CONTROL 'control + VK_MENU 'menu + VK_PAUSE 'pause + VK_SPACE 'space + VK_ESCAPE 'escape + VK_PRIOR 'prior + VK_NEXT 'next + VK_END 'end + VK_HOME 'home + VK_LEFT 'left + VK_UP 'up + VK_RIGHT 'right + VK_DOWN 'down + VK_SELECT 'select + VK_PRINT 'print + VK_EXECUTE 'execute + VK_INSERT 'insert + VK_DELETE 'delete + VK_HELP 'help + VK_NUMPAD0 'numpad0 + VK_NUMPAD1 'numpad1 + VK_NUMPAD2 'numpad2 + VK_NUMPAD3 'numpad3 + VK_NUMPAD4 'numpad4 + VK_NUMPAD5 'numpad5 + VK_NUMPAD6 'numpad6 + VK_NUMPAD7 'numpad7 + VK_NUMPAD8 'numpad8 + VK_NUMPAD9 'numpad9 + VK_MULTIPLY 'multiply + VK_ADD 'add + VK_SUBTRACT 'subtract + VK_DECIMAL 'decimal + VK_DIVIDE 'divide + VK_F1 'f1 + VK_F2 'f2 + VK_F3 'f3 + VK_F4 'f4 + VK_F5 'f5 + VK_F6 'f6 + VK_F7 'f7 + VK_F8 'f8 + VK_F9 'f9 + VK_F10 'f10 + VK_F11 'f11 + VK_F12 'f12 + VK_F13 'f13 + VK_F14 'f14 + VK_F15 'f15 + VK_F16 'f16 + VK_F17 'f17 + VK_F18 'f18 + VK_F19 'f19 + VK_F20 'f20 + VK_F21 'f21 + VK_F22 'f22 + VK_F23 'f23 + VK_F24 'f24 + VK_NUMLOCK 'numlock + VK_SCROLL 'scroll)) + + +(define (make-key-event just-check? wParam lParam is-char? is-up? hwnd) + (let ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))] + [shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))] + [caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))] + [alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)]) + (let-values ([(id other-shift other-altgr other-shift-altgr) + (if is-char? + ;; wParam is a character + (let ([id wParam] + [sc (THE_SCAN_CODE lParam)]) + ;; Remember scan codes to help with some key-release events: + (when (byte? id) + (hash-set! generic_ascii_code id sc)) + ;; Look for elements of find_shift_alts that have a different + ;; shift/AltGr state: + (let ([k (MapVirtualKeyW sc 1)]) + (if (zero? k) + (values (integer->char id) #f #f #f) + (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) k) + ;; Figure out whether it's different in the shift + ;; for AltGr dimension, or both: + (if (eq? (zero? (bitwise-and o #x100)) shift-down?) + ;; different Shift + (if (eq? (= (bitwise-and o #x600) #x6000) + (and control-down? alt-down?)) + ;; same AltGr + (values id o a sa) + ;; different AltGr + (values id s a o)) + ;; same Shift + (if (eq? (= (bitwise-and o #x600) #x6000) + (and control-down? alt-down?)) + ;; same AltGr + (values id s a sa) + ;; different AltGr + (values id s o sa))) + (values id s a sa)))))) + ;; wParam is a virtual key code + (let ([id (hash-ref win32->symbol wParam #f)] + [override-mapping? (and control-down? (not alt-down?))] + [try-generate-release + (lambda () + (let ([sc (THE_SCAN_CODE lParam)]) + (for/fold ([id #f]) ([i (in-range 256)] #:when (not id)) + (and (equal? sc (hash-ref generic_ascii_code i #f)) + (let ([id i]) + (if (id . < . 127) + (char->integer (char-downcase (integer->char id))) + id))))))]) + (if (not id) + (if (or override-mapping? is-up?) + ;; Non-AltGr Ctl- combination, or a release event: + ;; map manually, because the default mapping is + ;; unsatisfactory + ;; Set id to the unshifted key: + (let* ([id (bitwise-and (MapVirtualKeyW wParam 2) #xFFFF)] + [id (cond + [(zero? id) #f] + [(id . < . 128) + (char->integer (char-downcase (integer->char id)))] + [else id])]) + (let-values ([(s a sa) + ;; Look for shifted alternate: + (for/fold ([s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) wParam) + (if (not (zero? (bitwise-and o #x100))) + (if (= (bitwise-and o #x600) #x6000) + (values s a o) + (values o a sa)) + (if (= (bitwise-and o #x600) #x6000) + (values s o sa) + (values s a sa))) + (values s a sa)))]) + (if (and id shift-down?) + ;; shift was pressed, so swap role of shifted and unshifted + (values s id sa a) + (values id s a sa)))) + (values (try-generate-release) #f #f #f)) + (cond + [(and (not is-up?) (= wParam VK_CONTROL)) + ;; Don't generate control-key down events: + (values #f #f #f #f)] + [(and (not override-mapping?) (not is-up?) + ;; Let these get translated to WM_CHAR or skipped + ;; entirely: + (memq wParam + (list VK_ESCAPE VK_SHIFT VK_CONTROL + VK_SPACE VK_RETURN VK_TAB VK_BACK))) + (values #f #f #f #f)] + [(and (not id) is-up?) + (values (try-generate-release) #f #f #f)] + [else + (values id #f #f #f)]))))]) + (and id + (if just-check? + #t + (let* ([id (if (number? id) (integer->char id) id)] + [e (new key-event% + [key-code (if is-up? + 'release + id)] + [shift-down shift-down?] + [control-down control-down?] + [meta-down #f] + [alt-down alt-down?] + [x 0] + [y 0] + [time-stamp 0] + [caps-down caps-down?])]) + e)))))) + diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index f8feb528..6a2bf8f7 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -9,5 +9,5 @@ (def/public-unimplemented number) (def/public-unimplemented enable-top) (def/public-unimplemented delete) - (def/public-unimplemented append) + (define/public (append m l) (void)) (super-new)) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 3b0f521c..afe240e0 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -5,5 +5,5 @@ (provide menu-item%) (defclass menu-item% object% - (def/public-unimplemented id) + (define/public (id) this) (super-new)) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 06e79d85..7de02166 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -5,6 +5,10 @@ (provide menu%) (defclass menu% object% + (init label + callback + font) + (def/public-unimplemented select) (def/public-unimplemented get-font) (def/public-unimplemented set-width) @@ -15,8 +19,14 @@ (def/public-unimplemented enable) (def/public-unimplemented check) (def/public-unimplemented checked?) - (def/public-unimplemented append-separator) (def/public-unimplemented delete-by-position) (def/public-unimplemented delete) - (def/public-unimplemented append) + + (public [append-item append]) + (define (append-item i label help-str-or-submenu chckable?) + (void)) + + (define/public (append-separator) + (void)) + (super-new)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index c069a22e..650dbb7d 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -14,13 +14,13 @@ label) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "PLTPanel" #f (bitwise-ior WS_CHILD) 0 0 w h - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] @@ -28,8 +28,6 @@ (def/public-unimplemented get-label-position) (def/public-unimplemented set-label-position) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event) (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 5e785901..c8dd68f7 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -52,7 +52,7 @@ (define-unimplemented find-graphical-system-path) (define-unimplemented register-collecting-blit) (define-unimplemented unregister-collecting-blit) -(define (shortcut-visible-in-label? ?) #t) +(define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) @@ -71,7 +71,9 @@ (set-box! xb 1024) (set-box! yb 768)) (define-unimplemented bell) -(define-unimplemented hide-cursor) + +(define (hide-cursor) (void)) + (define-unimplemented end-busy-cursor) (define-unimplemented is-busy?) (define-unimplemented begin-busy-cursor) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 229c6aff..f1f1adda 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -1,8 +1,13 @@ #lang racket/base (require ffi/unsafe + racket/class + ffi/unsafe/alloc + ffi/unsafe/try-atomic "utils.rkt" "types.rkt" "const.rkt" + "key.rkt" + "wndclass.rkt" "../../lock.rkt" "../common/queue.rkt") @@ -19,26 +24,33 @@ (define _LPMSG _pointer) -(define-cstruct _MSG ([hwnd _HWND] - [message _UINT] - [wParam _WPARAM] - [lParam _LPARAM] - [time _DWORD] - [pt _POINT])) - (define-user32 GetQueueStatus (_wfun _UINT -> _DWORD)) (define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL)) (define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL)) (define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL)) (define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT)) (define-user32 PostQuitMessage (_wfun _int -> _void)) +(define-user32 EnumThreadWindows (_wfun _DWORD _fpointer _LPARAM -> _BOOL)) +(define-user32 GetWindow (_wfun _HWND _UINT -> _HWND)) +(define-kernel32 GetCurrentThreadId (_wfun -> _DWORD)) + +(define _enum_proc (_wfun _HWND _LPARAM -> _BOOL)) (define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void)) -(define msg (malloc _MSG 'raw)) +(define free-msg + ((deallocator) + (lambda (msg) + (free msg)))) + +(define malloc-msg + ((allocator free-msg) + (lambda () + (malloc _MSG 'raw)))) (define (events-ready?) - (not (zero? (GetQueueStatus QS_ALLINPUT)))) + ;; Check for events only since the last PeekMessage: + (not (zero? (LOWORD (GetQueueStatus QS_ALLINPUT))))) (define (install-wakeup fds) (pre-event-sync #t) @@ -47,17 +59,89 @@ (set-check-queue! events-ready?) (set-queue-wakeup! install-wakeup) +(define other-peek-evt (make-semaphore)) +(define peek-other-peek-evt (semaphore-peek-evt other-peek-evt)) + +(define (message-dequeue es hwnd) + ;; Called in the eventspace for hwnd: + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _long)]) + (atomically (hash-remove! t id)) + (let ([msg (malloc-msg)]) + (let loop () + (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) + ;; Since we called PeekMeessage in a thread other than the + ;; event-pump thread, see `other-peek-evt' so the pump + ;; knows to check again. + (unless (sync/timeout 0 peek-other-peek-evt) + (semaphore-post other-peek-evt)) + ;; Now handle the event: + (when v + (unless (generates-key-event? (cast msg _pointer _MSG-pointer)) + (TranslateMessage msg)) + (call-as-nonatomic-retry-point + (lambda () + ;; in atomic mode: + (DispatchMessageW msg))) + ;; Maybe there's another event for this window: + (loop)))) + (free-msg msg)))) + +(define (queue-message-dequeue es hwnd) + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _long)]) + (unless (hash-ref t id #f) + (hash-set! t id #t) + (queue-event es (lambda () (message-dequeue es hwnd)))))) + +;; For use only in the event-pump thread: +(define msg (malloc-msg)) + +(define (check-window-event hwnd data) + (let* ([root (let loop ([hwnd hwnd]) + (let ([p (GetWindow hwnd GW_OWNER)]) + (if p + (loop p) + hwnd)))] + [wx (any-hwnd->wx root)]) + (if wx + ;; One of our windows, so make sure its eventspace + ;; asks for the message: + (let ([v (PeekMessageW msg hwnd 0 0 PM_NOREMOVE)]) + (when v + (queue-message-dequeue (send wx get-eventspace) + hwnd))) + ;; Not our window, so dispatch any available events + (let loop () + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop))))) + #f)) + +(define check_window_event (function-ptr check-window-event _enum_proc)) + (define (dispatch-all-ready) (pre-event-sync #f) - (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) - (when v - (TranslateMessage msg) - (DispatchMessageW msg) - (dispatch-all-ready)))) + + ;; Windows uses messages above #x4000 to hilite items in the task bar, + ;; etc. In any case, these messages won't be handled by us, so they + ;; can't trigger callbacks. + (let loop () + (let ([v (PeekMessageW msg #f #x4000 #xFFFF PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop)))) + + ;; Per-window checking lets us put an event in the right + ;; eventspace: + (EnumThreadWindows (GetCurrentThreadId) check_window_event 0)) (define (win32-start-event-pump) (thread (lambda () (let loop () - (sync queue-evt) + (sync queue-evt other-peek-evt) (as-entry dispatch-all-ready) (loop))))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 3f19d936..e69f7e46 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -12,7 +12,9 @@ _UINT _BYTE _LONG + _SHORT _HRESULT + _WCHAR _HINSTANCE _HWND @@ -30,7 +32,11 @@ _permanent-string/utf-16 (struct-out POINT) _POINT _POINT-pointer - (struct-out RECT) _RECT _RECT-pointer) + (struct-out RECT) _RECT _RECT-pointer + (struct-out MSG) _MSG _MSG-pointer + + HIWORD + LOWORD) (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) @@ -44,6 +50,7 @@ (define _UINT _uint) (define _BYTE _uint8) (define _HRESULT _int32) +(define _WCHAR _int16) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -77,6 +84,7 @@ (cast p _pointer _string/utf-16))))) (define _LONG _long) +(define _SHORT _short) (define-cstruct _POINT ([x _LONG] [y _LONG])) @@ -85,3 +93,16 @@ [top _LONG] [right _LONG] [bottom _LONG])) + +(define-cstruct _MSG ([hwnd _HWND] + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) + +(define (HIWORD v) + (arithmetic-shift v -16)) +(define (LOWORD v) + (bitwise-and v #xFFFF)) + diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 074f2068..72527101 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -1,14 +1,16 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define - "../common/utils.rkt") + "../common/utils.rkt" + "types.rkt") (provide define-gdi32 define-user32 define-kernel32 define-comctl32 define-uxtheme - define-mz) + define-mz + failed) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -21,3 +23,10 @@ (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) + +(define-kernel32 GetLastError (_wfun -> _DWORD)) + +(define (failed w who) + (error who "call failed (~s)" + (GetLastError))) + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index aa97a4cb..3f9dca95 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -3,12 +3,15 @@ racket/class racket/draw "../../syntax.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" "utils.rkt" "types.rkt" "const.rkt" "wndclass.rkt" "queue.rkt" - "theme.rkt") + "theme.rkt" + "key.rkt") (provide window% queue-window-event @@ -17,6 +20,8 @@ CreateWindowExW GetWindowRect) +(define (unhide-cursor) (void)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -24,16 +29,20 @@ _int _int _int _int _HWND _HMENU _HINSTANCE _pointer -> _HWND)) -(define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) -(define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) +(define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> + (if r rect (failed 'GetWindowRect)))) +(define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> + (if r rect (failed 'GetClientRect)))) (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) -(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL)) +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'MoveWindow)))) + +(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) -(define-user32 ShowWindow (_wfun _HWND _int -> _BOOL)) (define SW_SHOW 5) (define SW_HIDE 0) @@ -48,38 +57,69 @@ (* 1/8 (arithmetic-shift v -16))))) (defclass window% object% - (init-field parent win32) + (init-field parent hwnd) (init style) - + (super-new) (define eventspace (current-eventspace)) - (set-win32-wx! win32 this) + (set-hwnd-wx! hwnd this) - (unless (memq 'invisible style) - (show #t)) - - (define/public (get-win32) win32) - (define/public (get-client-win32) win32) + (define/public (get-hwnd) hwnd) + (define/public (get-client-hwnd) hwnd) (define/public (get-eventspace) eventspace) - (define/public (wndproc w msg wparam lparam) - (DefWindowProcW w msg wparam lparam)) - + (define/public (wndproc w msg wParam lParam) + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + 0] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + 0] + [(= msg WM_SYSKEYDOWN) + (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close + (unhide-cursor) + (begin0 + (DefWindowProcW w msg wParam lParam) + (do-key wParam lParam #f #f)))] + [(= msg WM_KEYDOWN) + (do-key wParam lParam #f #f) + 0] + [(= msg WM_KEYUP) + (do-key wParam lParam #f #t) + 0] + [(= msg WM_SYSCHAR) + (when (= wParam VK_MENU) + (unhide-cursor) + (begin0 + (DefWindowProcW w msg wParam lParam) + (do-key wParam lParam #t #f)))] + [(= msg WM_CHAR) + (do-key wParam lParam #t #f) + 0] + [else + (DefWindowProcW w msg wParam lParam)])) + (define/public (show on?) (direct-show on?)) + (define shown? #f) (define/public (direct-show on?) - (void (ShowWindow win32 (if on? SW_SHOW SW_HIDE)))) - + (set! shown? (and on? #t)) + (unless on? (not-focus-child this)) + (ShowWindow hwnd (if on? SW_SHOW SW_HIDE))) + (unless (memq 'invisible style) + (show #t)) + (def/public-unimplemented on-drop-file) - (def/public-unimplemented pre-on-event) - (def/public-unimplemented pre-on-char) - (def/public-unimplemented on-size) - (def/public-unimplemented on-set-focus) - (def/public-unimplemented on-kill-focus) - (def/public-unimplemented get-handle) + + (define/public (on-size w h) (void)) + + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + (define/public (get-handle) hwnd) (define/public (is-window-enabled?) #t) @@ -89,51 +129,54 @@ (send parent is-enabled-to-root?))) (define/public (is-shown-to-root?) - (and (is-shown?) + (and shown? (send parent is-shown-to-root?))) (define/public (is-shown?) - #t) + shown?) (def/public-unimplemented set-phantom-size) (define/public (paint-children) (void)) (define/public (get-x) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-left r) (send parent get-x)))) (define/public (get-y) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-top r) (send parent get-y)))) (define/public (get-width) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-right r) (RECT-left r)))) (define/public (get-height) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-bottom r) (RECT-top r)))) (define/public (set-size x y w h) - (void - (if (or (= x -11111) - (= y -11111) - (= w -1) - (= h -1)) - (let ([r (GetWindowRect win32)]) - (MoveWindow win32 - (if (= x -11111) (RECT-left r) x) - (if (= y -11111) (RECT-right r) y) - (if (= w -1) (- (RECT-right r) (RECT-left r)) w) - (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) - #t)) - (MoveWindow win32 x y w h #t)))) + (if (or (= x -11111) + (= y -11111) + (= w -1) + (= h -1)) + (let ([r (GetWindowRect hwnd)]) + (MoveWindow hwnd + (if (= x -11111) (RECT-left r) x) + (if (= y -11111) (RECT-right r) y) + (if (= w -1) (- (RECT-right r) (RECT-left r)) w) + (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) + #t)) + (MoveWindow hwnd x y w h #t)) + (on-size w h) + (unless (and (= w -1) (= h -1)) + (on-resized)) + (refresh)) (define/public (move x y) (set-size x y -1 -1)) (define/public (auto-size label min-w min-h dw dh) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) + (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -151,7 +194,9 @@ (define/public (get-parent) parent) - (def/public-unimplemented refresh) + (define/public (refresh) (void)) + (define/public (on-resized) (void)) + (def/public-unimplemented screen-to-client) (def/public-unimplemented client-to-screen) @@ -162,16 +207,90 @@ (def/public-unimplemented get-position) (define/public (get-client-size w h) - (let ([r (GetClientRect (get-client-win32))]) + (let ([r (GetClientRect (get-client-hwnd))]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + + (define/public (get-size w h) + (let ([r (GetWindowRect (get-client-hwnd))]) (set-box! w (- (RECT-right r) (RECT-left r))) (set-box! h (- (RECT-bottom r) (RECT-top r))))) - (def/public-unimplemented get-size) (def/public-unimplemented fit) (def/public-unimplemented set-cursor) - (def/public-unimplemented set-focus) + + (define/public (set-focus) + (when (can-accept-focus?) + (set-top-focus this null hwnd))) + + (define/public (can-accept-focus?) + (child-can-accept-focus?)) + + (define/public (child-can-accept-focus?) + (and shown? + (send parent child-can-accept-focus?))) + + (define/public (set-top-focus win win-path hwnd) + (send parent set-top-focus win (cons this win-path) hwnd)) + (define/public (not-focus-child v) + (send parent not-focus-child v)) + (def/public-unimplemented gets-focus?) - (def/public-unimplemented centre)) + (def/public-unimplemented centre) + + (define/private (do-key wParam lParam is-char? is-up?) + (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) + (and e + (if (definitely-wants-event? e) + (begin + (queue-window-event this (lambda () (dispatch-on-char/sync e))) + #t) + (constrained-reply (get-eventspace) + (lambda () (dispatch-on-char e #t)) + #t))))) + + (define/public (definitely-wants-event? e) + #f) + + (define/public (dispatch-on-char/sync e) + (pre-event-refresh #t) + (dispatch-on-char e #f)) + (define/public (dispatch-on-char e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when (is-enabled-to-root?) (on-char e)) #t])) + + (define/public (dispatch-on-event/sync e) + (pre-event-refresh #f) + (dispatch-on-event e #f)) + (define/public (dispatch-on-event e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-event this e) #t] + [just-pre? #f] + [else (when (is-enabled-to-root?) (on-event e)) #t])) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (on-char e) (void)) + (define/public (on-event e) (void)) + + (define/private (pre-event-refresh key?) + ;; Since we break the connection between the + ;; Cocoa queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (void))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 1fd6c539..d06f8bad 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class + "../../lock.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -8,8 +9,9 @@ (provide hInstance DefWindowProcW - win32->wx - set-win32-wx! + hwnd->wx + any-hwnd->wx + set-hwnd-wx! MessageBoxW) ;; ---------------------------------------- @@ -17,12 +19,26 @@ (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) -(define (win32->wx win32) - (let ([p (GetWindowLongW win32 GWLP_USERDATA)]) +(define all-cells (make-hash)) + +(define (hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (and p (ptr-ref p _racket)))) -(define (set-win32-wx! win32 wx) - (SetWindowLongW win32 GWLP_USERDATA (malloc-immobile-cell wx))) +(define (set-hwnd-wx! hwnd wx) + (let ([c (malloc-immobile-cell wx)]) + (SetWindowLongW hwnd GWLP_USERDATA c) + (atomically (hash-set! all-cells (cast c _pointer _long) #t)))) + +(define (any-hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (and p + (atomically (hash-ref all-cells (cast p _pointer _long) #f)) + (let ([wx (ptr-ref p _racket)]) + (and wx + (ptr-equal? hwnd (send wx get-hwnd)) + wx))))) + ;; ---------------------------------------- @@ -63,7 +79,7 @@ #;(define-user32 PostQuitMessage (_wfun _int -> _void)) (define (wind-proc w msg wparam lparam) - (let ([wx (win32->wx w)]) + (let ([wx (hwnd->wx w)]) (if wx (send wx wndproc w msg wparam lparam) (DefWindowProcW w msg wparam lparam)))) From 82acccf2c3141fd3b1895cce795d30334ee883ed Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Sep 2010 07:03:02 -0600 Subject: [PATCH 242/462] win32 scrollbar event handling original commit: dd9a0772b367d3d55100351ee7efaac861d8384d --- collects/mred/private/wx/win32/canvas.rkt | 63 ++++++++++++++++++----- collects/mred/private/wx/win32/const.rkt | 16 ++++++ collects/mred/private/wx/win32/procs.rkt | 18 +++++-- 3 files changed, 82 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 4fbd9bbc..2144b414 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -6,6 +6,9 @@ "../../lock.rkt" "../common/canvas-mixin.rkt" "../common/backing-dc.rkt" + "../common/event.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -34,10 +37,11 @@ (define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int)) (define-user32 GetScrollPos (_wfun _HWND _int -> _int)) -(define-user32 SetScrollPos (_wfun _HWND _int _BOOL -> _int)) +(define-user32 SetScrollPos (_wfun _HWND _int _int _BOOL -> _int)) (define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer = (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) - (bitwise-ior SIF_RANGE SIF_POS SIF_PAGE) + (bitwise-ior SIF_RANGE SIF_POS + SIF_PAGE SIF_TRACKPOS) 0 0 0 0 0)) -> (r : _BOOL) -> (if r i (error 'GetScrollInfo "failed")))) @@ -52,7 +56,8 @@ [gl-config #f]) (inherit get-hwnd - get-client-size) + get-client-size + get-eventspace) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) @@ -74,7 +79,7 @@ (define hwnd (get-hwnd)) - (define/override (wndproc w msg wparam lparam) + (define/override (wndproc w msg wParam lParam) (cond [(= msg WM_PAINT) (let* ([ps (malloc 128)] @@ -85,7 +90,13 @@ (do-backing-flush this dc hdc)) (EndPaint hdc ps)) 0] - [else (super wndproc w msg wparam lparam)])) + [(= msg WM_HSCROLL) + (on-scroll-change SB_HORZ (LOWORD wParam)) + 0] + [(= msg WM_VSCROLL) + (on-scroll-change SB_VERT (LOWORD wParam)) + 0] + [else (super wndproc w msg wParam lParam)])) (define dc (new dc% [canvas this])) (send dc start-backing-retained) @@ -116,7 +127,7 @@ (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) - (InvalidateRect hwnd #f #t)) + (InvalidateRect hwnd #f #f)) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) @@ -170,14 +181,13 @@ (SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) (def/public-unimplemented set-background-to-gray) - (def/public-unimplemented on-scroll) (define/public (get-scroll-pos which) (GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) (define/public (get-scroll-range which) (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (+ (SCROLLINFO-nMax i) - (SCROLLINFO-nPage i) + (+ (- (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i)) 1))) (define/public (get-scroll-page which) (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) @@ -193,7 +203,7 @@ h-scroll-visible?) SIF_DISABLENOSCROLL 0))) - (set-SCROLLINFO-nMax! i (- v (SCROLLINFO-nPage i) -1)) + (set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1)) (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) (define/public (set-scroll-page which v) (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) @@ -203,11 +213,40 @@ h-scroll-visible?) SIF_DISABLENOSCROLL 0))) - (set-SCROLLINFO-nMax! i (- (+ (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) - v)) + (set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) + v)) (set-SCROLLINFO-nPage! i v) (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (define/public (on-scroll e) (void)) + (define/private (on-scroll-change dir part) + (let ([i (GetScrollInfo hwnd dir)]) + (let ([new-pos + (cond + [(= part SB_TOP) 0] + [(= part SB_BOTTOM) (SCROLLINFO-nMax i)] + [(= part SB_LINEUP) (max 0 (sub1 (SCROLLINFO-nPos i)))] + [(= part SB_LINEDOWN) (min (SCROLLINFO-nMax i) (add1 (SCROLLINFO-nPos i)))] + [(= part SB_PAGEUP) (max 0 (- (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))] + [(= part SB_PAGEDOWN) (min (SCROLLINFO-nMax i) (+ (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))] + [(= part SB_THUMBTRACK) (SCROLLINFO-nTrackPos i)] + [else (SCROLLINFO-nPos i)])]) + (unless (= new-pos (SCROLLINFO-nPos i)) + (set-SCROLLINFO-nPos! i new-pos) + (set-SCROLLINFO-fMask! i SIF_POS) + (SetScrollInfo hwnd dir i #t) + (queue-window-event + this + (lambda () + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] + [position new-pos])))) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))))) + (define/override (definitely-wants-event? e) #t) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 8eddac09..b61fcfdc 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -418,6 +418,22 @@ (define SIZE_MAXSHOW 3) (define SIZE_MAXHIDE 4) +(define SB_LINEUP 0) +(define SB_LINELEFT 0) +(define SB_LINEDOWN 1) +(define SB_LINERIGHT 1) +(define SB_PAGEUP 2) +(define SB_PAGELEFT 2) +(define SB_PAGEDOWN 3) +(define SB_PAGERIGHT 3) +(define SB_THUMBPOSITION 4) +(define SB_THUMBTRACK 5) +(define SB_TOP 6) +(define SB_LEFT 6) +(define SB_BOTTOM 7) +(define SB_RIGHT 7) +(define SB_ENDSCROLL 8) + (define SB_HORZ 0) (define SB_VERT 1) (define SB_CTL 2) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index c8dd68f7..f5bc7dab 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -1,7 +1,11 @@ #lang racket/base -(require racket/class +(require ffi/unsafe + racket/class "../../syntax.rkt" "theme.rkt" + "types.rkt" + "utils.rkt" + "const.rkt" racket/draw) (provide @@ -86,10 +90,18 @@ (define-unimplemented show-print-setup) (define-unimplemented can-show-print-setup?) +(define-user32 GetSysColor (_wfun _int -> _DWORD)) + +(define (GetRValue v) (bitwise-and v #xFF)) +(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) +(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) + (define (get-highlight-background-color) - (make-object color% 0 0 0)) + (let ([c (GetSysColor COLOR_HIGHLIGHT)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) (define (get-highlight-text-color) - (make-object color% 255 255 255)) + (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) (define-unimplemented make-screen-bitmap) From 58db19d72022961c93ffd31ed0cd014a0e8301e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Sep 2010 15:15:48 -0600 Subject: [PATCH 243/462] win32 menu and button callbacks original commit: bc0869f43cd46b1659209e1c3906beeabd468033 --- collects/mred/private/wx/win32/button.rkt | 10 +++++ collects/mred/private/wx/win32/const.rkt | 23 +++++++++++ collects/mred/private/wx/win32/frame.rkt | 15 ++++++- collects/mred/private/wx/win32/menu-bar.rkt | 43 ++++++++++++++++---- collects/mred/private/wx/win32/menu-item.rkt | 40 ++++++++++++++++-- collects/mred/private/wx/win32/menu.rkt | 37 +++++++++++++++-- collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/utils.rkt | 6 ++- collects/mred/private/wx/win32/window.rkt | 21 +++++++++- collects/mred/private/wxtop.rkt | 16 +++----- 10 files changed, 181 insertions(+), 32 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index df623434..e9c970cd 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class "../../syntax.rkt" + "../common/event.rkt" "item.rkt" "utils.rkt" "const.rkt" @@ -14,6 +15,8 @@ (init parent cb label x y w h style font) + (define callback cb) + (super-new [parent parent] [hwnd (CreateWindowExW 0 @@ -29,4 +32,11 @@ (auto-size label 40 12 12 0) + (define/public (do-command) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'button] + [time-stamp (current-milliseconds)]))))) + (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index b61fcfdc..375c7385 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -566,3 +566,26 @@ (define GW_HWNDPREV 3) (define GW_OWNER 4) (define GW_CHILD 5) + +(define MF_INSERT #x00000000) +(define MF_CHANGE #x00000080) +(define MF_APPEND #x00000100) +(define MF_DELETE #x00000200) +(define MF_REMOVE #x00001000) +(define MF_BYCOMMAND #x00000000) +(define MF_BYPOSITION #x00000400) +(define MF_SEPARATOR #x00000800) +(define MF_ENABLED #x00000000) +(define MF_GRAYED #x00000001) +(define MF_DISABLED #x00000002) +(define MF_UNCHECKED #x00000000) +(define MF_CHECKED #x00000008) +(define MF_USECHECKBITMAPS #x00000200) +(define MF_STRING #x00000000) +(define MF_BITMAP #x00000004) +(define MF_OWNERDRAW #x00000100) +(define MF_POPUP #x00000010) +(define MF_MENUBARBREAK #x00000020) +(define MF_MENUBREAK #x00000040) +(define MF_UNHILITE #x00000000) +(define MF_HILITE #x00000080) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index b2c47468..9ea93511 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -3,6 +3,7 @@ (only-in racket/list last) ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "../common/queue.rkt" "utils.ss" "const.ss" @@ -88,6 +89,10 @@ (when on? (set-frame-focus)) (queue-window-event this (lambda () (on-activate on?)))))) 0] + [(and (= msg WM_COMMAND) + (zero? (HIWORD wParam))) + (queue-window-event this (lambda () (on-menu-command (LOWORD wParam)))) + 0] [else (super wndproc w msg wParam lParam)])) (define/public (on-close) (void)) @@ -104,7 +109,9 @@ (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) - (def/public-unimplemented on-menu-command) + + (define/public (on-menu-command i) (void)) + (def/public-unimplemented on-mdi-activate) (define/public (enforce-size min-x min-y max-x max-y step-x step-y) @@ -153,7 +160,11 @@ (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) - (define/public (set-menu-bar mb) (void)) + (define menu-bar #f) + (define/public (set-menu-bar mb) + (atomically + (set! menu-bar mb) + (send mb set-parent this))) (def/public-unimplemented set-icon) (def/public-unimplemented iconize) diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 6a2bf8f7..33df806d 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -1,13 +1,40 @@ #lang scheme/base (require scheme/class - "../../syntax.rkt") + ffi/unsafe + "../../lock.rkt" + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "const.rkt") (provide menu-bar%) -(defclass menu-bar% object% - (def/public-unimplemented set-label-top) - (def/public-unimplemented number) - (def/public-unimplemented enable-top) - (def/public-unimplemented delete) - (define/public (append m l) (void)) - (super-new)) +(define-user32 CreateMenu (_wfun -> _HMENU)) +(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL) + -> (unless r (failed 'SetMenu)))) +(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DrawMenuBar)))) + +(define menu-bar% + (class object% + (super-new) + + (define hmenu (CreateMenu)) + + (define menus null) + + (def/public-unimplemented set-label-top) + (def/public-unimplemented number) + (def/public-unimplemented enable-top) + (def/public-unimplemented delete) + + (public [append-item append]) + (define (append-item m lbl) + (let ([l (append menus (list m))]) + (atomically + (set! menus l) + (send m set-parent this lbl hmenu)))) + + (define/public (set-parent f) + (SetMenu (send f get-hwnd) hmenu) + (DrawMenuBar (send f get-hwnd))))) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index afe240e0..57e57e7e 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -1,9 +1,43 @@ #lang scheme/base -(require scheme/class +(require ffi/unsafe + scheme/class "../../syntax.rkt") -(provide menu-item%) +(provide menu-item% + id-to-menu-item) + +;; Menu itens are identified by 16-bit numbers, so we have +;; to keep a hash mapping them to menu items. +(define ids (make-hash)) + +(define (id-to-menu-item id) + (let ([wb (hash-ref ids id #f)]) + (and wb (weak-box-value wb)))) (defclass menu-item% object% - (define/public (id) this) + + (define id + (let loop () + (let ([id (add1 (random #x7FFE))]) + (let ([wb (hash-ref ids id #f)]) + (if (and wb + (weak-box-value wb)) + (loop) + (begin + (hash-set! ids id (make-weak-box this)) + id)))))) + + (define parent #f) + (define label #f) + (define checkable? #f) + + (define/public (set-parent p lbl chkbl?) + (set! parent p) + (set! label lbl) + (set! checkable? chkbl?) + id) + + (public [get-id id]) + (define (get-id) id) + (super-new)) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 7de02166..5e01d3ba 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -1,14 +1,38 @@ #lang scheme/base (require scheme/class - "../../syntax.rkt") + ffi/unsafe + "../../lock.rkt" + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "menu-item.rkt") (provide menu%) +(define-user32 CreatePopupMenu (_wfun -> _HMENU)) +(define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL) + -> (unless r (failed 'AppendMenuW)))) + (defclass menu% object% - (init label + (init lbl callback font) + (define label lbl) + (define parent #f) + (define items null) + + (define hmenu (CreatePopupMenu)) + + (define/public (set-parent p lbl parent-hmenu) + (set! label lbl) + (set! parent p) + (AppendMenuW parent-hmenu + (bitwise-ior MF_POPUP MF_STRING) + hmenu + lbl)) + (def/public-unimplemented select) (def/public-unimplemented get-font) (def/public-unimplemented set-width) @@ -24,9 +48,14 @@ (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) - (void)) + (let ([id (send (id-to-menu-item i) set-parent this label chckable?)]) + (atomically + (set! items (append items (list i))) + (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))) (define/public (append-separator) - (void)) + (atomically + (set! items (append items (list #f))) + (AppendMenuW hmenu MF_SEPARATOR #f #f))) (super-new)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index f5bc7dab..7be32341 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -6,6 +6,7 @@ "types.rkt" "utils.rkt" "const.rkt" + "menu-item.rkt" racket/draw) (provide @@ -84,7 +85,6 @@ (define-unimplemented get-display-depth) (define-unimplemented is-color-display?) (define-unimplemented file-selector) -(define-unimplemented id-to-menu-item) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 72527101..f84af2c3 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -10,7 +10,9 @@ define-comctl32 define-uxtheme define-mz - failed) + failed + + SendMessageW) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -30,3 +32,5 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 3f9dca95..34a082e1 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -36,8 +36,6 @@ (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) -(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) - (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) -> (unless r (failed 'MoveWindow)))) @@ -46,6 +44,11 @@ (define SW_SHOW 5) (define SW_HIDE 0) +(define-cstruct _NMHDR + ([hwndFrom _HWND] + [idFrom _pointer] + [code _UINT])) + (define-user32 GetDialogBaseUnits (_fun -> _LONG)) (define measure-dc #f) @@ -99,6 +102,20 @@ [(= msg WM_CHAR) (do-key wParam lParam #t #f) 0] + [(= msg WM_COMMAND) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if wx + (begin + (send wx do-command) + 0) + (DefWindowProcW w msg wParam lParam)))] + [(= msg WM_NOTIFY) + (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] + [control-hwnd (NMHDR-hwndFrom nmhdr)] + [wx (any-hwnd->wx control-hwnd)]) + (when wx (send wx do-command))) + 0] [else (DefWindowProcW w msg wParam lParam)])) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 80cb5d14..a0858c48 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -680,17 +680,11 @@ (when mb (set! menu-bar mb)) (super set-menu-bar mb))] [on-menu-command - (entry-point - (lambda (id) - (let ([wx (wx:id-to-menu-item id)]) - (let ([go (lambda () - (do-command (wx->mred wx) (make-object wx:control-event% 'menu)))]) - (if (eq? 'windows (system-type)) - ;; Windows: need trampoline - (wx:queue-callback - (entry-point (lambda () (go))) - wx:middle-queue-key) - (go))))))] + (entry-point + (lambda (id) + (let ([wx (wx:id-to-menu-item id)]) + (when wx + (do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))] [on-menu-click (entry-point (lambda () From 8980e911926e118376c13c38930013815b0b3d30 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 23 Sep 2010 20:35:14 -0600 Subject: [PATCH 244/462] win32: several control classes original commit: f2bad07fb82f4b966099df575cf9571f8507eb1e --- collects/mred/private/wx/win32/button.rkt | 95 +++++++---- collects/mred/private/wx/win32/check-box.rkt | 24 ++- collects/mred/private/wx/win32/choice.rkt | 91 +++++++++-- collects/mred/private/wx/win32/const.rkt | 8 + collects/mred/private/wx/win32/dc.rkt | 4 +- collects/mred/private/wx/win32/frame.rkt | 7 +- collects/mred/private/wx/win32/gauge.rkt | 68 ++++++-- .../mred/private/wx/win32/group-panel.rkt | 69 +++++++- collects/mred/private/wx/win32/hbitmap.rkt | 53 +++++++ collects/mred/private/wx/win32/item.rkt | 27 +++- collects/mred/private/wx/win32/list-box.rkt | 99 +++++++++--- collects/mred/private/wx/win32/menu.rkt | 23 ++- collects/mred/private/wx/win32/message.rkt | 62 +++++++- collects/mred/private/wx/win32/panel.rkt | 54 ++++--- collects/mred/private/wx/win32/procs.rkt | 6 - collects/mred/private/wx/win32/queue.rkt | 12 +- collects/mred/private/wx/win32/radio-box.rkt | 131 +++++++++++++-- collects/mred/private/wx/win32/slider.rkt | 149 +++++++++++++++++- collects/mred/private/wx/win32/types.rkt | 9 +- collects/mred/private/wx/win32/utils.rkt | 24 ++- collects/mred/private/wx/win32/window.rkt | 66 +++++--- collects/mred/private/wx/win32/wndclass.rkt | 2 +- 22 files changed, 907 insertions(+), 176 deletions(-) create mode 100644 collects/mred/private/wx/win32/hbitmap.rkt diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index e9c970cd..4cb7e5dc 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -1,42 +1,81 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" "../common/event.rkt" "item.rkt" "utils.rkt" "const.rkt" "window.rkt" - "wndclass.rkt") + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") -(provide button%) +(provide base-button% + button%) -(defclass button% item% - (inherit auto-size) +(define base-button% + (class item% + (inherit set-control-font auto-size get-hwnd) - (init parent cb label x y w h style font) + (init parent cb label x y w h style font) - (define callback cb) + (define callback cb) - (super-new [parent parent] - [hwnd - (CreateWindowExW 0 - "BUTTON" - label - (bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-hwnd) - #f - hInstance - #f)] - [style style]) + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) - (auto-size label 40 12 12 0) + (define/public (get-class) "BUTTON") + (define/public (get-flags) BS_PUSHBUTTON) + + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + + (set-control-font font) + + (define/public (auto-size-button label) + (cond + [bitmap? + (auto-size label 0 0 4 4)] + [else + (auto-size label 40 12 12 0)])) + (auto-size-button label) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'button] + [time-stamp (current-milliseconds)]))))) + + (def/public-unimplemented set-border))) + +(define button% + (class base-button% + (super-new))) - (define/public (do-command) - (queue-window-event this (lambda () - (callback this - (new control-event% - [event-type 'button] - [time-stamp (current-milliseconds)]))))) - (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 2479deac..1cf398dc 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -1,11 +1,21 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "item.rkt") +#lang racket/base +(require racket/class + "../../syntax.rkt" + "button.rkt" + "item.rkt" + "const.rkt") (provide check-box%) -(defclass check-box% item% +(defclass check-box% base-button% + (inherit auto-size) + + (super-new) + + (define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX)) + + (define/override (auto-size-button label) + (auto-size label 0 0 20 0)) + (def/public-unimplemented set-value) - (def/public-unimplemented get-value) - (super-new)) + (def/public-unimplemented get-value)) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 935a35b0..075501ad 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -1,14 +1,85 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide choice%) -(defclass choice% item% - (def/public-unimplemented set-selection) - (def/public-unimplemented get-selection) - (def/public-unimplemented number) - (def/public-unimplemented clear) - (def/public-unimplemented append) - (super-new)) +(define CBS_DROPDOWNLIST #x0003) +(define CB_INSERTSTRING #x014A) +(define CB_SETCURSEL #x014E) +(define CB_GETCURSEL #x0147) +(define CBN_SELENDOK 9) + +(define choice% + (class item% + (init parent cb label + x y w h + choices style font) + (inherit auto-size set-control-font + set-size) + + (define callback cb) + + (define hwnd + (CreateWindowExW 0 + "COMBOBOX" + label + (bitwise-ior WS_CHILD CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define num-choices (length choices)) + + (for ([s (in-list choices)] + [i (in-naturals)]) + (SendMessageW/str hwnd CB_INSERTSTRING i s)) + + (SendMessageW hwnd CB_SETCURSEL 0 0) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + ;; setting the choice height somehow sets the + ;; popup-menu size, not the control that you see + (auto-size choices 0 0 40 0 + (lambda (w h) + (set-size -11111 -11111 w (* h 8)))) + + (define/override (is-command? cmd) + (= cmd CBN_SELENDOK)) + + (define/public (do-command control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))))) + + + (define/public (set-selection i) + (SendMessageW hwnd CB_SETCURSEL i 0)) + + (define/public (get-selection i) + (SendMessageW hwnd CB_GETCURSEL 0 0)) + + (define/public (number) num-choices) + + (def/public-unimplemented clear) + (def/public-unimplemented append))) + diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 375c7385..7104752e 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -272,6 +272,7 @@ (define WM_PALETTECHANGED #x0311) (define WM_HOTKEY #x0312) +(define WM_USER #x0400) ;; Class styles (define CS_VREDRAW #x0001) @@ -589,3 +590,10 @@ (define MF_MENUBREAK #x00000040) (define MF_UNHILITE #x00000000) (define MF_HILITE #x00000080) + +(define BM_SETIMAGE #x00F7) +(define IMAGE_BITMAP 0) +(define BN_CLICKED 0) + +(define SW_SHOW 5) +(define SW_HIDE 0) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 37375244..2ddc3c95 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -18,7 +18,7 @@ cancel-flush-delay) (define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HDC -> _int)) +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) (define win32-bitmap% (class bitmap% @@ -33,7 +33,7 @@ (begin0 (cairo_win32_surface_create_with_ddb hdc CAIRO_FORMAT_RGB24 w h) - (ReleaseDC hdc)))))) + (ReleaseDC hwnd hdc)))))) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 9ea93511..55e32c68 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -5,6 +5,7 @@ "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" + "../common/freeze.rkt" "utils.ss" "const.ss" "types.ss" @@ -93,6 +94,11 @@ (zero? (HIWORD wParam))) (queue-window-event this (lambda () (on-menu-command (LOWORD wParam)))) 0] + [(= msg WM_INITMENU) + (constrained-reply (get-eventspace) + (lambda () (on-menu-click)) + (void)) + 0] [else (super wndproc w msg wParam lParam)])) (define/public (on-close) (void)) @@ -151,7 +157,6 @@ [else 'other]))] [else #f])) - (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index 9051cf18..e3f085ac 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -1,13 +1,63 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide gauge%) -(defclass gauge% item% - (def/public-unimplemented get-value) - (def/public-unimplemented set-value) - (def/public-unimplemented get-range) - (def/public-unimplemented set-range) - (super-new)) +(define PBS_VERTICAL #x04) +(define PBM_SETRANGE (+ WM_USER 1)) +(define PBM_SETPOS (+ WM_USER 2)) +(define PBM_GETRANGE (+ WM_USER 7));wParam = return (TRUE ? low : high). lParam = PPBRANGE or NULL +(define PBM_GETPOS (+ WM_USER 8)) + +(define gauge% + (class item% + (inherit set-size) + + (init parent + label + rng + x y w h + style + font) + + (define hwnd + (CreateWindowExW 0 + "msctls_progress32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'vertical style) + PBS_VERTICAL + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-range rng) + + (if (memq 'horizontal style) + (set-size -11111 -11111 100 24) + (set-size -11111 -11111 24 100)) + + (define/public (get-value) + (SendMessageW hwnd PBM_GETPOS 0 0)) + (define/public (set-value v) + (void (SendMessageW hwnd PBM_SETPOS v 0))) + (define/public (get-range) + (SendMessageW hwnd PBM_GETRANGE 0 0)) + (define/public (set-range v) + (void (SendMessageW hwnd PBM_SETRANGE 0 (MAKELPARAM 0 v)))))) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index f50287c2..79e218cf 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -1,9 +1,66 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "panel.rkt" + "wndclass.rkt" + "types.rkt") (provide group-panel%) -(defclass group-panel% window% - (super-new)) + +(define group-panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) + + (inherit auto-size set-control-font) + + (define hwnd + (CreateWindowExW 0 + "BUTTON" + (or label "") + (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define client-hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD WS_VISIBLE) + 0 0 w h + hwnd + #f + hInstance + #f)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (define/override (get-client-hwnd) + client-hwnd) + + (define label-h 0) + + (set-control-font #f) + (auto-size label 0 0 0 0 + (lambda (w h) + (set! label-h h) + (set-size -11111 -11111 (+ w 10) (+ h 10)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (unless (or (= w -1) (= h -1)) + (MoveWindow client-hwnd 3 (+ label-h 3) (- w 6) (- h label-h 6) #t))))) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt new file mode 100644 index 00000000..b8d7caf6 --- /dev/null +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -0,0 +1,53 @@ +#lang scheme/base +(require ffi/unsafe + racket/draw/cairo + racket/draw + racket/draw/local + racket/class + "types.rkt" + "utils.rkt" + "const.rkt") + +(provide bitmap->hbitmap) + +(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) +(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) + -> (unless r (failed 'DeleteDC)))) +(define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP)) +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) + +(define (bitmap->hbitmap bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [col (GetSysColor COLOR_BTNFACE)] + [to-frac (lambda (v) (/ v 255.0))] + [screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [hbitmap (CreateCompatibleBitmap screen-hdc w h)] + [old-hbitmap (SelectObject hdc hbitmap)]) + (ReleaseDC #f screen-hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create s)]) + (cairo_surface_destroy s) + (cairo_set_source_rgba cr + (to-frac (GetRValue col)) + (to-frac (GetGValue col)) + (to-frac (GetBValue col)) + 1.0) + (cairo_paint cr) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_set_source cr p) + (cairo_pattern_destroy p)) + (cairo_destroy cr) + (SelectObject hdc old-hbitmap) + (DeleteDC hdc) + hbitmap))) + + diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index c76201cd..6aaa3475 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -1,12 +1,27 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "window.rkt") + "../common/event.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide item%) (defclass item% window% - (def/public-unimplemented set-label) + (inherit get-hwnd) + + (super-new) + + (define/override (gets-focus?) #t) + + (define/public (set-label s) + (SetWindowTextW (get-hwnd) s)) + (def/public-unimplemented get-label) - (def/public-unimplemented command) - (super-new)) + (def/public-unimplemented command)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 0ea610c1..b03def3b 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -1,26 +1,81 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide list-box%) -(defclass list-box% item% - (def/public-unimplemented get-label-font) - (def/public-unimplemented set-string) - (def/public-unimplemented set-first-visible-item) - (def/public-unimplemented set) - (def/public-unimplemented get-selections) - (def/public-unimplemented get-first-item) - (def/public-unimplemented number-of-visible-items) - (def/public-unimplemented number) - (def/public-unimplemented get-selection) - (def/public-unimplemented set-data) - (def/public-unimplemented get-data) - (def/public-unimplemented selected?) - (def/public-unimplemented set-selection) - (def/public-unimplemented select) - (def/public-unimplemented delete) - (def/public-unimplemented clear) - (def/public-unimplemented append) - (super-new)) +(define WS_EX_CLIENTEDGE #x00000200) + +(define LBS_NOTIFY #x0001) +(define LBS_MULTIPLESEL #x0008) +(define LBS_HASSTRINGS #x0040) +(define LBS_MULTICOLUMN #x0200) +(define LBS_WANTKEYBOARDINPUT #x0400) +(define LBS_EXTENDEDSEL #x0800) +(define LBS_DISABLENOSCROLL #x1000) + +(define LB_ADDSTRING #x0180) + +(define list-box% + (class item% + (init parent cb + label kind x y w h + choices style + font label-font) + + (inherit set-size set-control-font) + + (define hwnd + (CreateWindowExW WS_EX_CLIENTEDGE + "LISTBOX" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(memq 'extended style) LBS_MULTIPLESEL] + [(memq 'multiple style) LBS_EXTENDEDSEL] + [else 0])) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + (set-size -11111 -11111 40 40) + + (def/public-unimplemented get-label-font) + (def/public-unimplemented set-string) + (def/public-unimplemented set-first-visible-item) + (def/public-unimplemented set) + (def/public-unimplemented get-selections) + (def/public-unimplemented get-first-item) + (def/public-unimplemented number-of-visible-items) + (def/public-unimplemented number) + (def/public-unimplemented get-selection) + (def/public-unimplemented set-data) + (def/public-unimplemented get-data) + (def/public-unimplemented selected?) + (def/public-unimplemented set-selection) + (def/public-unimplemented select) + (def/public-unimplemented delete) + (def/public-unimplemented clear) + (def/public-unimplemented append))) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 5e01d3ba..4991ab20 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -13,6 +13,7 @@ (define-user32 CreatePopupMenu (_wfun -> _HMENU)) (define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL) -> (unless r (failed 'AppendMenuW)))) +(define-user32 EnableMenuItem (_wfun _HMENU _UINT _UINT -> _BOOL)) (defclass menu% object% (init lbl @@ -40,18 +41,28 @@ (def/public-unimplemented set-label) (def/public-unimplemented set-help-string) (def/public-unimplemented number) - (def/public-unimplemented enable) + + (define/public (enable id on?) + (for ([i (in-list items)] + [pos (in-naturals)]) + (when (and i (eq? id (send i id))) + (void + (EnableMenuItem hmenu pos (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED))))))) + (def/public-unimplemented check) (def/public-unimplemented checked?) (def/public-unimplemented delete-by-position) (def/public-unimplemented delete) (public [append-item append]) - (define (append-item i label help-str-or-submenu chckable?) - (let ([id (send (id-to-menu-item i) set-parent this label chckable?)]) - (atomically - (set! items (append items (list i))) - (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))) + (define (append-item id label help-str-or-submenu chckable?) + (let ([i (id-to-menu-item id)]) + (when i + (let ([id (send i set-parent this label chckable?)]) + (atomically + (set! items (append items (list i))) + (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))))) (define/public (append-separator) (atomically diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index cd1468e6..2f469752 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -1,10 +1,60 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide message%) -(defclass message% item% - (def/public-unimplemented get-font) - (super-new)) +(define STM_SETIMAGE #x0172) + +(define SS_LEFT #x00000000) +(define SS_BITMAP #x0000000E) + +(define message% + (class item% + (inherit auto-size set-control-font get-hwnd) + + (init parent label + x y + style font) + + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) + + (define/public (get-class) "STATIC") + + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + SS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + + (set-control-font font) + + (auto-size label 0 0 0 0))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 650dbb7d..8c63bc60 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -5,29 +5,37 @@ "wndclass.rkt" "const.rkt") -(provide panel%) +(provide panel-mixin + panel%) -(defclass panel% window% - (init parent - x y w h - style - label) +(define (panel-mixin %) + (class % + (super-new) + + (define lbl-pos 'horizontal) + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (def/public-unimplemented on-paint) + (define/public (set-item-cursor x y) (void)) + (def/public-unimplemented get-item-cursor))) - (super-new [parent parent] - [hwnd - (CreateWindowExW 0 - "PLTPanel" - #f - (bitwise-ior WS_CHILD) - 0 0 w h - (send parent get-hwnd) - #f - hInstance - #f)] - [style style]) +(define panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) - (def/public-unimplemented get-label-position) - (def/public-unimplemented set-label-position) - (def/public-unimplemented on-paint) - (define/public (set-item-cursor x y) (void)) - (def/public-unimplemented get-item-cursor)) + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7be32341..d7eb37f5 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -90,12 +90,6 @@ (define-unimplemented show-print-setup) (define-unimplemented can-show-print-setup?) -(define-user32 GetSysColor (_wfun _int -> _DWORD)) - -(define (GetRValue v) (bitwise-and v #xFF)) -(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) -(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) - (define (get-highlight-background-color) (let ([c (GetSysColor COLOR_HIGHLIGHT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index f1f1adda..901345d6 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -112,13 +112,11 @@ (queue-message-dequeue (send wx get-eventspace) hwnd))) ;; Not our window, so dispatch any available events - (let loop () - (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) - (when v - (TranslateMessage msg) - (DispatchMessageW msg) - (loop))))) - #f)) + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg)))) + #t)) (define check_window_event (function-ptr check-window-event _enum_proc)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 2170afd4..2f9973e2 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -1,13 +1,126 @@ #lang scheme/base -(require scheme/class - "../../syntax.rkt" - "item.rkt") +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide radio-box%) -(defclass radio-box% item% - (def/public-unimplemented button-focus) - (def/public-unimplemented set-selection) - (def/public-unimplemented number) - (def/public-unimplemented get-selection) - (super-new)) +(define SEP 4) +(define BM_SETCHECK #x00F1) + +(define radio-box% + (class item% + (init parent cb label + x y w h + labels + val + style + font) + + (inherit auto-size set-control-font) + + (define callback cb) + (define current-value val) + + (define hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define radio-hwnds + (let loop ([y 0] [w 0] [labels labels]) + (if (null? labels) + (begin + (MoveWindow hwnd 0 0 w y #t) + null) + (let* ([label (car labels)] + [bitmap? (and (label . is-a? . bitmap%) + (send label ok?))] + [radio-hwnd + (CreateWindowExW 0 "BUTTON" + (if (string? label) + label + "") + (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + hwnd + #f + hInstance + #f)]) + (when bitmap? + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (ShowWindow radio-hwnd SW_SHOW) + (set-control-font font radio-hwnd) + (let-values ([(w h) + (auto-size label 0 0 20 4 (lambda (w h) + (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) + (values w h)))]) + (cons radio-hwnd + (loop (+ y SEP h) (max w h) (cdr labels)))))))) + + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + + (super-new [parent parent] + [hwnd hwnd] + [extra-hwnds radio-hwnds] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (for/or ([radio-hwnd (in-list radio-hwnds)]) + (ptr-equal? a-hwnd radio-hwnd)))) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command control-hwnd) + (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)] + [pos (in-naturals)]) + (if (ptr-equal? control-hwnd radio-hwnd) + pos + i))]) + (unless (= val current-value) + (set-selection val) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))))))) + + + (def/public-unimplemented button-focus) + + (define/public (set-selection val) + (atomically + (unless (= val current-value) + (unless (= current-value -1) + (SendMessageW (list-ref radio-hwnds current-value) BM_SETCHECK 0 0)) + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + (set! current-value val)))) + + (define/public (get-selection) current-value) + + (define/public (number) (length radio-hwnds)))) + diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index f547ed74..8974e658 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -1,11 +1,148 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide slider%) +(define TBS_VERT #x0002) +(define TBS_HORZ #x0000) + +(define TBM_GETPOS WM_USER) +(define TBM_GETRANGEMIN (+ WM_USER 1)) +(define TBM_GETRANGEMAX (+ WM_USER 2)) +(define TBM_GETTIC (+ WM_USER 3)) +(define TBM_SETTIC (+ WM_USER 4)) +(define TBM_SETPOS (+ WM_USER 5)) +(define TBM_SETRANGE (+ WM_USER 6)) +(define TBM_SETRANGEMIN (+ WM_USER 7)) +(define TBM_SETRANGEMAX (+ WM_USER 8)) + +(define SS_CENTER #x00000001) + +(define THICKNESS 24) +(define MIN_LENGTH 100) + (defclass slider% item% - (def/public-unimplemented set-value) - (def/public-unimplemented get-value) - (super-new)) + (init parent cb + label + val lo hi + x y w + style + font) + (inherit set-control-font + auto-size) + + (define vertical? (memq 'vertical style)) + + (define panel-hwnd + (if (memq 'plain style) + #f + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f))) + + (define slider-hwnd + (CreateWindowExW 0 + "msctls_trackbar32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if vertical? + TBS_VERT + TBS_HORZ) + (if panel-hwnd + WS_VISIBLE + 0)) + 0 0 0 0 + (or panel-hwnd + (send parent get-client-hwnd)) + #f + hInstance + #f)) + + (define value-hwnd + (and panel-hwnd + (CreateWindowExW 0 + "STATIC" + (format "~s" val) + (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) + 0 0 0 0 + panel-hwnd + #f + hInstance + #f))) + + (define hwnd (or panel-hwnd slider-hwnd)) + + (super-new [parent parent] + [hwnd hwnd] + [extra-hwnds + (if panel-hwnd + (list slider-hwnd value-hwnd) + null)] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (and panel-hwnd + (or (ptr-equal? slider-hwnd a-hwnd) + (ptr-equal? value-hwnd a-hwnd))))) + + (when value-hwnd + (set-control-font font value-hwnd)) + + (define value-w 0) + (define value-h 0) + + (if panel-hwnd + (auto-size (list (format "~s" lo) + (format "~s" hi)) + 0 0 0 0 (lambda (w h) + (set! value-w w) + (set! value-h h) + (if vertical? + (set-size -11111 -11111 (+ THICKNESS w) (max h MIN_LENGTH)) + (set-size -11111 -11111 (max w MIN_LENGTH) (+ THICKNESS h))))) + (if vertical? + (set-size -11111 -11111 THICKNESS MIN_LENGTH) + (set-size -11111 -11111 MIN_LENGTH THICKNESS))) + + (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) + (set-value val) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when panel-hwnd + (unless (or (= w -1) (= h -1)) + (if vertical? + (let ([dx (quotient (- w THICKNESS value-w) 2)]) + (MoveWindow slider-hwnd dx 0 THICKNESS h #T) + (MoveWindow value-hwnd (+ dx THICKNESS) (quotient (- h value-h) 2) value-w value-h #t)) + (let ([dy (quotient (- h THICKNESS value-h) 2)]) + (MoveWindow slider-hwnd 0 dy w THICKNESS #t) + (MoveWindow value-hwnd (quotient (- w value-w) 2) (+ dy THICKNESS) value-w value-h #t)))))) + + (define/override (control-scrolled) + (when value-hwnd + (let ([val (get-value)]) + (SetWindowTextW value-hwnd (format "~s" val))))) + + (define/public (set-value val) + (SendMessageW slider-hwnd TBM_SETPOS 1 val)) + + (define/public (get-value) + (SendMessageW slider-hwnd TBM_GETPOS 0 0))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index e69f7e46..f3fb0b7d 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -24,6 +24,7 @@ _HBRUSH _HDC _HFONT + _HBITMAP _COLORREF @@ -36,7 +37,9 @@ (struct-out MSG) _MSG _MSG-pointer HIWORD - LOWORD) + LOWORD + MAKELONG + MAKELPARAM) (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) @@ -60,6 +63,7 @@ (define _HBRUSH (_cpointer/null 'HBRUSH)) (define _HDC (_cpointer/null 'HDC)) (define _HFONT (_cpointer/null 'HFONT)) +(define _HBITMAP (_cpointer/null 'HBITMAP)) (define _COLORREF _DWORD) @@ -106,3 +110,6 @@ (define (LOWORD v) (bitwise-and v #xFFFF)) +(define (MAKELONG a b) + (bitwise-ior (arithmetic-shift b 16) a)) +(define (MAKELPARAM a b) (MAKELONG a b)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index f84af2c3..814bea15 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,7 +12,11 @@ define-mz failed - SendMessageW) + SendMessageW SendMessageW/str + GetSysColor GetRValue GetGValue GetBValue + MoveWindow + ShowWindow + SetWindowTextW) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -28,9 +32,25 @@ (define-kernel32 GetLastError (_wfun -> _DWORD)) -(define (failed w who) +(define (failed who) (error who "call failed (~s)" (GetLastError))) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) + #:c-id SendMessageW) +(define-user32 GetSysColor (_wfun _int -> _DWORD)) + +(define (GetRValue v) (bitwise-and v #xFF)) +(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) +(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) + +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'MoveWindow)))) + +(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) + + +(define-user32 SetWindowTextW (_wfun _HWND _string/utf-16 -> (r : _BOOL) + -> (unless r (failed 'SetWindowText)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 34a082e1..69350ee6 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -36,14 +36,6 @@ (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) -(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) - -> (unless r (failed 'MoveWindow)))) - -(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) - -(define SW_SHOW 5) -(define SW_HIDE 0) - (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -61,17 +53,23 @@ (defclass window% object% (init-field parent hwnd) - (init style) + (init style + [extra-hwnds null]) (super-new) (define eventspace (current-eventspace)) (set-hwnd-wx! hwnd this) + (for ([extra-hwnd (in-list extra-hwnds)]) + (set-hwnd-wx! extra-hwnd this)) (define/public (get-hwnd) hwnd) (define/public (get-client-hwnd) hwnd) (define/public (get-eventspace) eventspace) + + (define/public (is-hwnd? a-hwnd) + (ptr-equal? hwnd a-hwnd)) (define/public (wndproc w msg wParam lParam) (cond @@ -105,20 +103,33 @@ [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] [wx (any-hwnd->wx control-hwnd)]) - (if wx + (if (and wx (send wx is-command? (HIWORD wParam))) (begin - (send wx do-command) + (send wx do-command control-hwnd) 0) (DefWindowProcW w msg wParam lParam)))] [(= msg WM_NOTIFY) + #; (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] [control-hwnd (NMHDR-hwndFrom nmhdr)] [wx (any-hwnd->wx control-hwnd)]) (when wx (send wx do-command))) 0] + [(or (= msg WM_HSCROLL) + (= msg WM_VSCROLL)) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if wx + (begin + (send wx control-scrolled) + 0) + (DefWindowProcW w msg wParam lParam)))] [else (DefWindowProcW w msg wParam lParam)])) + (define/public (is-command? cmd) #f) + (define/public (control-scrolled) #f) + (define/public (show on?) (direct-show on?)) @@ -190,21 +201,40 @@ (define/public (move x y) (set-size x y -1 -1)) - (define/public (auto-size label min-w min-h dw dh) + (define/public (set-control-font font [hwnd hwnd]) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) + (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)) + + (define/public (auto-size label min-w min-h dw dh + [resize + (lambda (w h) (set-size -11111 -11111 w h))]) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] [font (make-object font% 8 'system)]) (send dc set-font font) (set! measure-dc dc))) - (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)] + (let-values ([(w h d a) (let loop ([label label]) + (cond + [(null? label) (values 0 0 0 0)] + [(label . is-a? . bitmap%) + (values (send label get-width) + (send label get-height) + 0 + 0)] + [(pair? label) + (let-values ([(w1 h1 d1 a1) + (loop (car label))] + [(w2 h2 d2 a2) + (loop (cdr label))]) + (values (max w1 w2) (max h1 h2) + (max d1 d1) (max a1 a2)))] + [else + (send measure-dc get-text-extent label #f #t)]))] [(->int) (lambda (v) (inexact->exact (floor v)))]) - (set-size -11111 -11111 - (max (->int (+ w dw)) (->int (* dlu-x min-w))) - (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) + (resize (max (->int (+ w dw)) (->int (* dlu-x min-w))) + (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) (def/public-unimplemented popup-menu) (def/public-unimplemented center) @@ -252,7 +282,7 @@ (define/public (not-focus-child v) (send parent not-focus-child v)) - (def/public-unimplemented gets-focus?) + (define/public (gets-focus?) #f) (def/public-unimplemented centre) (define/private (do-key wParam lParam is-char? is-up?) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index d06f8bad..e0092a26 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -36,7 +36,7 @@ (atomically (hash-ref all-cells (cast p _pointer _long) #f)) (let ([wx (ptr-ref p _racket)]) (and wx - (ptr-equal? hwnd (send wx get-hwnd)) + (send wx is-hwnd? hwnd) wx))))) From d7197a36db40955abf1b0ba86af903b1a0e8c638 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 25 Sep 2010 07:07:30 -0600 Subject: [PATCH 245/462] win32 dialogs, etc. original commit: 1402583ad2775be07cb5f832101b1a1fc946ae65 --- collects/mred/private/wx/win32/button.rkt | 7 +- collects/mred/private/wx/win32/canvas.rkt | 4 +- collects/mred/private/wx/win32/const.rkt | 1 + collects/mred/private/wx/win32/dialog.rkt | 100 +++++++++++++++-- collects/mred/private/wx/win32/frame.rkt | 46 ++++---- .../mred/private/wx/win32/group-panel.rkt | 4 +- collects/mred/private/wx/win32/message.rkt | 2 +- collects/mred/private/wx/win32/panel.rkt | 4 +- collects/mred/private/wx/win32/radio-box.rkt | 5 +- collects/mred/private/wx/win32/tab-panel.rkt | 103 +++++++++++++++++- collects/mred/private/wx/win32/theme.rkt | 12 +- collects/mred/private/wx/win32/types.rkt | 4 +- collects/mred/private/wx/win32/window.rkt | 49 +++++++-- collects/mred/private/wx/win32/wndclass.rkt | 22 +++- 14 files changed, 299 insertions(+), 64 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 4cb7e5dc..066e4f3d 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -15,6 +15,8 @@ (provide base-button% button%) +(define BM_SETSTYLE #x00F4) + (define base-button% (class item% (inherit set-control-font auto-size get-hwnd) @@ -72,7 +74,10 @@ [event-type 'button] [time-stamp (current-milliseconds)]))))) - (def/public-unimplemented set-border))) + (define/public (set-border on?) + (SendMessageW (get-hwnd) BM_SETSTYLE + (if on? BS_DEFPUSHBUTTON BS_PUSHBUTTON) + 1)))) (define button% (class base-button% diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 2144b414..8e8fbf0d 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -79,7 +79,7 @@ (define hwnd (get-hwnd)) - (define/override (wndproc w msg wParam lParam) + (define/override (wndproc w msg wParam lParam default) (cond [(= msg WM_PAINT) (let* ([ps (malloc 128)] @@ -96,7 +96,7 @@ [(= msg WM_VSCROLL) (on-scroll-change SB_VERT (LOWORD wParam)) 0] - [else (super wndproc w msg wParam lParam)])) + [else (super wndproc w msg wParam lParam default)])) (define dc (new dc% [canvas this])) (send dc start-backing-retained) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 7104752e..2e56a8d7 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -403,6 +403,7 @@ (define CW_USEDEFAULT #x80000000) (define WS_EX_LAYERED #x00080000) +(define WS_EX_TRANSPARENT #x00000020) (define LWA_ALPHA #x00000002) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index 837102e1..6456686a 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -1,14 +1,92 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + (only-in racket/list last) + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "utils.ss" + "const.ss" + "types.ss" + "window.rkt" + "frame.rkt" + "wndclass.rkt") (provide dialog%) -(defclass dialog% window% - (def/public-unimplemented system-menu) - (def/public-unimplemented set-title) - (def/public-unimplemented enforce-size) - (def/public-unimplemented on-close) - (def/public-unimplemented on-activate) - (super-new)) +(define _WORD _short) + +(define-cstruct _DLGTEMPLATE + ([style _DWORD] + [dwExtendedStyle _DWORD] + [cdit _WORD] + [x _short] + [y _short] + [cx _short] + [cy _short] + [menu _short] ; 0 + [class _short] ; 0 + [title _short])) ; 0 + +(define _INT_PTR _long) +(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) + + +(define DS_MODALFRAME #x80) + +(define-user32 CreateDialogIndirectParamW (_wfun _HINSTANCE + _DLGTEMPLATE-pointer + _HWND + _fpointer + -> _HWND)) + +(define (dlgproc w msg wParam lParam) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wParam lParam + (lambda (w msg wParam lParam) 0)) + 0))) + +(define dialog-proc (function-ptr dlgproc _DialogProc)) + +(define dialog-level-counter 0) + +(define dialog% + (class frame% + (super-new) + + (define/override (create-frame parent label w h) + (let ([hwnd + (CreateDialogIndirectParamW hInstance + (make-DLGTEMPLATE + (bitwise-ior DS_MODALFRAME WS_CAPTION WS_SYSMENU WS_THICKFRAME) + 0 0 + 0 0 w h + 0 0 0) + (and parent (send parent get-hwnd)) + dialog-proc)]) + (SetWindowTextW hwnd label) + (MoveWindow hwnd 0 0 w h #t) + hwnd)) + + (define/override (is-dialog?) #t) + + (define dialog-level 0) + (define/override (get-dialog-level) dialog-level) + + (define/override (frame-relative-dialog-status win) + (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))) + + (define/override (direct-show on?) + (when on? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (unless on? + (set! dialog-level 0)) + (super direct-show on?)))) + diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 55e32c68..36740fe4 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -6,9 +6,10 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" - "utils.ss" - "const.ss" - "types.ss" + "utils.rkt" + "const.rkt" + "types.rkt" + "theme.rkt" "window.rkt" "wndclass.rkt") @@ -30,17 +31,19 @@ on-size pre-on-char pre-on-event) + (define/public (create-frame parent label w h) + (CreateWindowExW (bitwise-ior WS_EX_LAYERED) + "PLTFrame" + (if label label "") + WS_OVERLAPPEDWINDOW + 0 0 w h + #f + #f + hInstance + #f)) + (super-new [parent #f] - [hwnd - (CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED) - "PLTFrame" - (if label label "") - WS_OVERLAPPEDWINDOW - 0 0 w h - #f - #f - hInstance - #f)] + [hwnd (create-frame parent label w h)] [style (cons 'invisible style)]) (define hwnd (get-hwnd)) @@ -67,7 +70,7 @@ (define/private (stdret f d) (if (is-dialog?) d f)) - (define/override (wndproc w msg wParam lParam) + (define/override (wndproc w msg wParam lParam default) (cond [(= msg WM_CLOSE) (queue-window-event this (lambda () @@ -99,7 +102,7 @@ (lambda () (on-menu-click)) (void)) 0] - [else (super wndproc w msg wParam lParam)])) + [else (super wndproc w msg wParam lParam default)])) (define/public (on-close) (void)) @@ -147,15 +150,10 @@ (define/override (call-pre-on-char w e) (pre-on-char w e)) - (define dialog-level 0) + (define/override (get-dialog-level) 0) + (define/public (frame-relative-dialog-status win) - (cond - [(is-dialog?) (let ([dl (send win get-dialog-level)]) - (cond - [(= dl dialog-level) 'same] - [(dl . > . dialog-level) #f] - [else 'other]))] - [else #f])) + #f) (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) @@ -170,6 +168,8 @@ (atomically (set! menu-bar mb) (send mb set-parent this))) + + (define/override (is-frame?) #t) (def/public-unimplemented set-icon) (def/public-unimplemented iconize) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 79e218cf..1233d3f2 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -36,7 +36,7 @@ (define client-hwnd (CreateWindowExW 0 - "PLTPanel" + "PLTTabPanel" #f (bitwise-ior WS_CHILD WS_VISIBLE) 0 0 w h @@ -53,7 +53,7 @@ client-hwnd) (define label-h 0) - + (set-control-font #f) (auto-size label 0 0 0 0 (lambda (w h) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 2f469752..0f6ca833 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -35,7 +35,7 @@ (super-new [parent parent] [hwnd - (CreateWindowExW 0 + (CreateWindowExW (if (string? label) WS_EX_TRANSPARENT 0) (get-class) (if (string? label) label diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 8c63bc60..9ca17008 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -30,7 +30,9 @@ (super-new [parent parent] [hwnd (CreateWindowExW 0 - "PLTPanel" + (if (send parent is-frame?) + "PLTPanel" + "PLTTabPanel") #f (bitwise-ior WS_CHILD) 0 0 w h diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 2f9973e2..49d30a1f 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -34,7 +34,7 @@ (define hwnd (CreateWindowExW 0 - "PLTPanel" + "PLTTabPanel" #f (bitwise-ior WS_CHILD) 0 0 w h @@ -53,7 +53,8 @@ [bitmap? (and (label . is-a? . bitmap%) (send label ok?))] [radio-hwnd - (CreateWindowExW 0 "BUTTON" + (CreateWindowExW WS_EX_TRANSPARENT + "BUTTON" (if (string? label) label "") diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 386d01e4..8582a056 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -1,9 +1,100 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "panel.rkt" + "wndclass.rkt" + "types.rkt") (provide tab-panel%) -(defclass tab-panel% window% - (super-new)) +(define TCIF_TEXT #x0001) +(define TCM_SETUNICODEFORMAT #x2005) +(define TCM_FIRST #x1300) +(define TCM_INSERTITEMW (+ TCM_FIRST 62)) + +(define-cstruct _TCITEMW + ([mask _UINT] + [dwState _DWORD] + [dwStateMask _DWORD] + [pszText _permanent-string/utf-16] + [cchTextMax _int] + [iImage _int] + [lParam _LPARAM])) + +(define tab-panel% + (class (panel-mixin window%) + (init parent + x y w h + style + choices) + + (define callback void) + + (inherit auto-size set-control-font) + + (define hwnd + (CreateWindowExW 0 + "SysTabControl32" + "" + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define client-hwnd + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD WS_VISIBLE) + 0 0 w h + hwnd + #f + hInstance + #f)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (define/override (get-client-hwnd) + client-hwnd) + + (SendMessageW hwnd TCM_SETUNICODEFORMAT 1 0) + + (atomically + (let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)]) + (set-TCITEMW-mask! item TCIF_TEXT) + (for ([i (in-list choices)] + [pos (in-naturals)]) + (set-TCITEMW-pszText! item i) + (SendMessageW hwnd TCM_INSERTITEMW pos (cast item _pointer _LPARAM)) + (free (TCITEMW-pszText item))) + (free item))) + + (define tab-height 0) + + (set-control-font #f) + (auto-size choices 0 0 0 0 #:combine-width + + (lambda (w h) + (set! tab-height (+ h 6)) + (set-size -11111 -11111 + (+ w (* 6 (length choices))) + (+ h 12)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (unless (or (= w -1) (= h -1)) + (MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t))) + + (define/public (set-callback cb) + (set! callback cb)))) + diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt index 70b6f79f..5a469d72 100644 --- a/collects/mred/private/wx/win32/theme.rkt +++ b/collects/mred/private/wx/win32/theme.rkt @@ -7,7 +7,9 @@ (provide get-theme-logfont get-theme-font-face get-theme-font-size - _LOGFONT-pointer) + _LOGFONT-pointer + DrawThemeParentBackground + EnableThemeDialogTexture) (define _HTHEME (_cpointer 'HTHEME)) @@ -59,6 +61,14 @@ (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r)) f))) +(define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r))))) + +(define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT) + -> (when (negative? r) + (error 'EnableThemeDialogTexture "failed: ~s" (bitwise-and #xFFFF r))))) + (define BP_PUSHBUTTON 1) (define PBS_NORMAL 1) (define TMT_FONT 210) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index f3fb0b7d..0c41a48a 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -83,9 +83,7 @@ (let ([c (malloc len _uint16 'raw)]) (memcpy c p len _uint16) c)))))) - (lambda (p) - (and p - (cast p _pointer _string/utf-16))))) + (lambda (p) p))) (define _LONG _long) (define _SHORT _short) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 69350ee6..b91cfe6d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -22,6 +22,9 @@ (define (unhide-cursor) (void)) +(define WM_PRINT #x0317) +(define WM_PRINTCLIENT #x0318) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -35,6 +38,8 @@ (if r rect (failed 'GetClientRect)))) (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) +(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) + -> (when (zero? r) (failed 'FillRect)))) (define-cstruct _NMHDR ([hwndFrom _HWND] @@ -51,6 +56,25 @@ (values (* 1/4 (bitwise-and v #xFFFF)) (* 1/8 (arithmetic-shift v -16))))) +(define-cstruct _LOGBRUSH + ([lbStyle _UINT] + [lbColor _COLORREF] + [lbHatch _pointer])) + +(define BS_NULL 1) +(define transparent-logbrush (make-LOGBRUSH BS_NULL 0 #f)) + +(define-gdi32 CreateBrushIndirect (_wfun _LOGBRUSH-pointer -> _HBRUSH)) + +(define TRANSPARENT 1) +(define-gdi32 SetBkMode (_wfun _HDC _int -> (r : _int) + -> (when (zero? r) (failed 'SetBkMode)))) + +(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) +(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) + -> (unless r (failed 'InvalidateRect)))) + (defclass window% object% (init-field parent hwnd) (init style @@ -71,7 +95,7 @@ (define/public (is-hwnd? a-hwnd) (ptr-equal? hwnd a-hwnd)) - (define/public (wndproc w msg wParam lParam) + (define/public (wndproc w msg wParam lParam default) (cond [(= msg WM_SETFOCUS) (queue-window-event this (lambda () (on-set-focus))) @@ -83,7 +107,7 @@ (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close (unhide-cursor) (begin0 - (DefWindowProcW w msg wParam lParam) + (default w msg wParam lParam) (do-key wParam lParam #f #f)))] [(= msg WM_KEYDOWN) (do-key wParam lParam #f #f) @@ -95,7 +119,7 @@ (when (= wParam VK_MENU) (unhide-cursor) (begin0 - (DefWindowProcW w msg wParam lParam) + (default w msg wParam lParam) (do-key wParam lParam #t #f)))] [(= msg WM_CHAR) (do-key wParam lParam #t #f) @@ -107,7 +131,7 @@ (begin (send wx do-command control-hwnd) 0) - (DefWindowProcW w msg wParam lParam)))] + (default w msg wParam lParam)))] [(= msg WM_NOTIFY) #; (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] @@ -123,9 +147,9 @@ (begin (send wx control-scrolled) 0) - (DefWindowProcW w msg wParam lParam)))] + (default w msg wParam lParam)))] [else - (DefWindowProcW w msg wParam lParam)])) + (default w msg wParam lParam)])) (define/public (is-command? cmd) #f) (define/public (control-scrolled) #f) @@ -208,7 +232,9 @@ (define/public (auto-size label min-w min-h dw dh [resize - (lambda (w h) (set-size -11111 -11111 w h))]) + (lambda (w h) (set-size -11111 -11111 w h))] + #:combine-width [combine-w max] + #:combine-height [combine-h max]) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -228,8 +254,8 @@ (loop (car label))] [(w2 h2 d2 a2) (loop (cdr label))]) - (values (max w1 w2) (max h1 h2) - (max d1 d1) (max a1 a2)))] + (values (combine-w w1 w2) (combine-h h1 h2) + (combine-h d1 d1) (combine-h a1 a2)))] [else (send measure-dc get-text-extent label #f #t)]))] [(->int) (lambda (v) (inexact->exact (floor v)))]) @@ -240,6 +266,7 @@ (def/public-unimplemented center) (define/public (get-parent) parent) + (define/public (is-frame?) #f) (define/public (refresh) (void)) (define/public (on-resized) (void)) @@ -337,7 +364,9 @@ ;; re-sync the display in case a stream of ;; events (e.g., key repeat) have a corresponding ;; stream of screen updates. - (void))) + (void)) + + (define/public (get-dialog-level) (send parent get-dialog-level))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index e0092a26..f446348f 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -74,6 +74,9 @@ (define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR)) (define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON)) +(define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL) + -> (if r i (failed 'GetClassInfoW)))) + (define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) #;(define-user32 PostQuitMessage (_wfun _int -> _void)) @@ -81,7 +84,7 @@ (define (wind-proc w msg wparam lparam) (let ([wx (hwnd->wx w)]) (if wx - (send wx wndproc w msg wparam lparam) + (send wx wndproc w msg wparam lparam DefWindowProcW) (DefWindowProcW w msg wparam lparam)))) (define hInstance (GetModuleHandleW #f)) @@ -125,4 +128,21 @@ #f ; menu "PLTPanel"))) +(define controls-are-transparent? #f) + +(void (RegisterClassW (make-WNDCLASS 0 + wind-proc + 0 + 0 + hInstance + #f + (LoadCursorW #f IDC_ARROW) + (if controls-are-transparent? + #f ; transparent + (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p)) + #f ; menu + "PLTTabPanel"))) + (define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int)) From 8ea36a72f538988444784e504e841200fea1cb8b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 27 Sep 2010 05:37:59 -0600 Subject: [PATCH 246/462] win32 widgets, mouse events, and cursors original commit: 604afc180302a54105fbd333850f611e17d9ceba --- collects/mred/private/gdi.rkt | 12 +- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 2 + .../mred/private/wx/common/cursor-draw.rkt | 4 +- collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 2 + collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/button.rkt | 7 +- collects/mred/private/wx/win32/canvas.rkt | 4 + collects/mred/private/wx/win32/check-box.rkt | 14 +- collects/mred/private/wx/win32/choice.rkt | 10 +- collects/mred/private/wx/win32/cursor.rkt | 110 +++++- collects/mred/private/wx/win32/frame.rkt | 83 ++++- collects/mred/private/wx/win32/gauge.rkt | 7 +- .../mred/private/wx/win32/group-panel.rkt | 11 +- collects/mred/private/wx/win32/item.rkt | 68 +++- collects/mred/private/wx/win32/list-box.rkt | 140 ++++++- collects/mred/private/wx/win32/message.rkt | 52 ++- collects/mred/private/wx/win32/panel.rkt | 51 ++- collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 9 +- collects/mred/private/wx/win32/queue.rkt | 10 +- collects/mred/private/wx/win32/radio-box.rkt | 20 +- collects/mred/private/wx/win32/slider.rkt | 19 +- collects/mred/private/wx/win32/tab-panel.rkt | 4 +- collects/mred/private/wx/win32/utils.rkt | 14 +- collects/mred/private/wx/win32/window.rkt | 351 ++++++++++++++---- collects/mred/private/wx/win32/wndclass.rkt | 28 +- collects/tests/gracket/item.rkt | 2 +- 29 files changed, 873 insertions(+), 165 deletions(-) diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 01bcbf9c..36b3cad6 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -238,9 +238,15 @@ [(windows) 1] [else 2])) - (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system)) - (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system)) - (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system)) + (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) (define view-control-font (if (eq? 'macosx (system-type)) (make-object wx:font% (- (wx:get-control-font-size) 1) 'system) normal-control-font)) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index b912d0f3..24805c7e 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -68,6 +68,7 @@ fill-private-color cancel-quit get-control-font-size + get-control-font-size-in-pixels? get-double-click-time run-printout file-creator-and-type diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index c25e3801..267be1c3 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -33,6 +33,7 @@ run-printout get-double-click-time get-control-font-size + get-control-font-size-in-pixels? cancel-quit fill-private-color flush-display @@ -75,6 +76,7 @@ (define (get-double-click-time) 500) (define (get-control-font-size) 13) +(define (get-control-font-size-in-pixels?) #f) (define (cancel-quit) (void)) (define-unimplemented fill-private-color) (define-unimplemented write-resource) diff --git a/collects/mred/private/wx/common/cursor-draw.rkt b/collects/mred/private/wx/common/cursor-draw.rkt index 9eb6d458..78149554 100644 --- a/collects/mred/private/wx/common/cursor-draw.rkt +++ b/collects/mred/private/wx/common/cursor-draw.rkt @@ -8,10 +8,10 @@ draw-ne/sw draw-bullseye) -(define (make-cursor-image draw-proc) +(define (make-cursor-image draw-proc [smoothing 'aligned]) (let* ([bm (make-object bitmap% 16 16 #f #t)] [dc (make-object bitmap-dc% bm)]) - (send dc set-smoothing 'aligned) + (send dc set-smoothing smoothing) (draw-proc dc 16 16) (send dc set-bitmap #f) bm)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index ae282dda..19a1bec5 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -68,6 +68,7 @@ fill-private-color cancel-quit get-control-font-size + get-control-font-size-in-pixels? get-double-click-time run-printout file-creator-and-type diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 8455301b..a59ced41 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -31,6 +31,7 @@ get-double-click-time key-symbol-to-integer get-control-font-size + get-control-font-size-in-pixels? cancel-quit fill-private-color flush-display @@ -75,6 +76,7 @@ (define (get-double-click-time) 250) (define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 10) ;; FIXME +(define (get-control-font-size-in-pixels?) #f) ;; FIXME (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 222204a2..14d6f126 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -48,6 +48,7 @@ fill-private-color cancel-quit get-control-font-size + get-control-font-size-in-pixels? get-double-click-time run-printout file-creator-and-type diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 066e4f3d..85e40db4 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -19,7 +19,8 @@ (define base-button% (class item% - (inherit set-control-font auto-size get-hwnd) + (inherit set-control-font auto-size get-hwnd + subclass-control) (init parent cb label x y w h style font) @@ -29,7 +30,7 @@ (and (label . is-a? . bitmap%) (send label ok?))) - (define/public (get-class) "BUTTON") + (define/public (get-class) "PLTBUTTON") (define/public (get-flags) BS_PUSHBUTTON) (super-new [parent parent] @@ -64,6 +65,8 @@ (auto-size label 40 12 12 0)])) (auto-size-button label) + (subclass-control (get-hwnd)) + (define/override (is-command? cmd) (= cmd BN_CLICKED)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 8e8fbf0d..0fd6d312 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -250,6 +250,10 @@ (define/override (definitely-wants-event? e) #t) + (define/public (on-combo-select i) (void)) + (define/public (set-combo-text s) (void)) + (define/public (append-combo-item s) (void)) + (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) (def/public-unimplemented view-start) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 1cf398dc..ab62b61b 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -3,12 +3,17 @@ "../../syntax.rkt" "button.rkt" "item.rkt" + "utils.rkt" "const.rkt") (provide check-box%) +(define BM_GETCHECK #x00F0) +(define BM_SETCHECK #x00F1) + (defclass check-box% base-button% - (inherit auto-size) + (inherit auto-size + get-hwnd) (super-new) @@ -17,5 +22,8 @@ (define/override (auto-size-button label) (auto-size label 0 0 20 0)) - (def/public-unimplemented set-value) - (def/public-unimplemented get-value)) + (define/public (set-value v) + (void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0))) + + (define/public (get-value) + (positive? (bitwise-and #x3 (SendMessageW (get-hwnd) BM_GETCHECK 0 0))))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 075501ad..7b0a5480 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -25,13 +25,14 @@ x y w h choices style font) (inherit auto-size set-control-font - set-size) + set-size + subclass-control) (define callback cb) (define hwnd (CreateWindowExW 0 - "COMBOBOX" + "PLTCOMBOBOX" label (bitwise-ior WS_CHILD CBS_DROPDOWNLIST WS_HSCROLL WS_VSCROLL @@ -61,6 +62,9 @@ (lambda (w h) (set-size -11111 -11111 w (* h 8)))) + + (subclass-control hwnd) + (define/override (is-command? cmd) (= cmd CBN_SELENDOK)) @@ -75,7 +79,7 @@ (define/public (set-selection i) (SendMessageW hwnd CB_SETCURSEL i 0)) - (define/public (get-selection i) + (define/public (get-selection) (SendMessageW hwnd CB_GETCURSEL 0 0)) (define/public (number) num-choices) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index e5351284..ab98a79f 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -1,11 +1,113 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../common/cursor-draw.rkt" "../../syntax.rkt") -(provide cursor-driver%) +(provide cursor-driver% + get-arrow-cursor + get-wait-cursor) + +(define (MAKEINTRESOURCE v) v) + +(define IDC_ARROW (MAKEINTRESOURCE 32512)) +(define IDC_IBEAM (MAKEINTRESOURCE 32513)) +(define IDC_WAIT (MAKEINTRESOURCE 32514)) +(define IDC_APPSTARTING (MAKEINTRESOURCE 32650)) +(define IDC_CROSS (MAKEINTRESOURCE 32515)) +(define IDC_UPARROW (MAKEINTRESOURCE 32516)) +(define IDC_SIZENWSE (MAKEINTRESOURCE 32642)) +(define IDC_SIZENESW (MAKEINTRESOURCE 32643)) +(define IDC_SIZEWE (MAKEINTRESOURCE 32644)) +(define IDC_SIZENS (MAKEINTRESOURCE 32645)) +(define IDC_SIZEALL (MAKEINTRESOURCE 32646)) +(define IDC_NO (MAKEINTRESOURCE 32648)) +(define IDC_HAND (MAKEINTRESOURCE 32649)) +(define IDC_HELP (MAKEINTRESOURCE 32651)) + +(define-user32 LoadCursorW (_wfun _HINSTANCE _LONG -> _HCURSOR)) + +(define-user32 CreateCursor (_wfun _HINSTANCE + _int ; x + _int ; y + _int ; width + _int ; height + _pointer ; AND + _pointer ; XOR + -> _HCURSOR)) + +(define handles (make-hasheq)) +(define (load-cursor num) + (or (hash-ref handles num #f) + (let ([h (LoadCursorW #f num)]) + (hash-set! handles num h) + h))) + +(define (get-arrow-cursor) + (load-cursor IDC_ARROW)) +(define (get-wait-cursor) + (load-cursor IDC_APPSTARTING)) (defclass cursor-driver% object% - (define/public (set-standard c) (void)) + (define handle #f) + + (define/public (set-standard sym) + (case sym + [(arrow) + (set! handle (load-cursor IDC_ARROW))] + [(cross) + (set! handle (load-cursor IDC_CROSS))] + [(hand) + (set! handle (load-cursor IDC_HAND))] + [(ibeam) + (set! handle (load-cursor IDC_IBEAM))] + [(size-n/s) + (set! handle (load-cursor IDC_SIZENS))] + [(size-e/w) + (set! handle (load-cursor IDC_SIZEWE))] + [(size-nw/se) + (set! handle (load-cursor IDC_SIZENWSE))] + [(size-ne/sw) + (set! handle (load-cursor IDC_SIZENESW))] + [(watch) + (set! handle (load-cursor IDC_APPSTARTING))] + [(bullseye) + (set-image (make-cursor-image draw-bullseye 'unsmoothed) #f 8 8)] + [(blank) + (set-image #f #f 0 0)])) + + (define/public (set-image image mask hot-spot-x hot-spot-y + [ai (make-bytes (/ (* 16 16) 8) 255)] + [xi (make-bytes (/ (* 16 16) 8) 0)]) + (let ([s (make-bytes (* 16 16 4) 0)]) + (when image + (send image get-argb-pixels 0 0 16 16 s) + (if mask + (send mask get-argb-pixels 0 0 16 16 s #t) + (send image get-argb-pixels 0 0 16 16 s #t))) + (for* ([i (in-range 16)] + [j (in-range 16)]) + (let ([pos (* 4 (+ (* j 16) i))]) + (when (positive? (bytes-ref s pos)) + ;; black bit in mask + (let ([bpos (+ (* j (/ 16 8)) (quotient i 8))] + [bit (arithmetic-shift 1 (- 7 (modulo i 8)))]) + (bytes-set! ai bpos (- (bytes-ref ai bpos) bit)) + (unless (and (zero? (bytes-ref s (+ 1 pos))) + (zero? (bytes-ref s (+ 2 pos))) + (zero? (bytes-ref s (+ 3 pos)))) + ;; white cursor pixel + (bytes-set! xi bpos (+ (bytes-ref xi bpos) bit))))))) + (set! handle + (CreateCursor hInstance hot-spot-x hot-spot-y + 16 16 + ai xi)))) + + (define/public (get-handle) handle) (def/public-unimplemented ok?) (super-new)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 36740fe4..7154f107 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -11,14 +11,26 @@ "types.rkt" "theme.rkt" "window.rkt" - "wndclass.rkt") + "wndclass.rkt" + "cursor.rkt") -(provide frame%) +(provide frame% + display-size + display-origin) (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) (define-user32 GetActiveWindow (_wfun -> _HWND)) (define-user32 SetFocus (_wfun _HWND -> _HWND)) +(define mouse-frame #f) + +(define (display-origin xb yb ?) + (set-box! xb 0) + (set-box! yb 0)) +(define (display-size xb yb ?) + (set-box! xb 1024) + (set-box! yb 768)) + (defclass frame% window% (init parent label @@ -29,10 +41,13 @@ is-shown? get-eventspace on-size - pre-on-char pre-on-event) + get-size + get-position + pre-on-char pre-on-event + reset-cursor-in-child) (define/public (create-frame parent label w h) - (CreateWindowExW (bitwise-ior WS_EX_LAYERED) + (CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED) "PLTFrame" (if label label "") WS_OVERLAPPEDWINDOW @@ -64,6 +79,7 @@ (super show on?)) (define/override (direct-show on?) + (when (eq? mouse-frame this) (set! mouse-frame #f)) (register-frame-shown this on?) (super direct-show on?)) @@ -150,11 +166,70 @@ (define/override (call-pre-on-char w e) (pre-on-char w e)) + (define/override (generate-parent-mouse-ins mk) + ;; assert: in-window is always the panel child + (unless (eq? mouse-frame this) + (when mouse-frame + (let ([win mouse-frame]) + (set! mouse-frame #f) + (send win send-leaves mk))) + (set! mouse-frame this)) + #f) + + (define/override (reset-cursor default) + (if wait-cursor-on? + (void (SetCursor (get-wait-cursor))) + (when saved-child + (reset-cursor-in-child saved-child default)))) + (define/override (get-dialog-level) 0) (define/public (frame-relative-dialog-status win) #f) + (define wait-cursor-on? #f) + (define/public (set-wait-cursor-mode on?) + (set! wait-cursor-on? on?) + (when (eq? mouse-frame this) + (if on? + (void (SetCursor (get-wait-cursor))) + (reset-cursor (get-arrow-cursor))))) + (define/public (is-wait-cursor-on?) + wait-cursor-on?) + + (define/override (center mode wrt) + (let ([sw (box 0)] + [sh (box 0)] + [w (box 0)] + [h (box 0)] + [x (box 0)] + [y (box 0)]) + (display-size sw sh #f) + (get-size w h) + (MoveWindow hwnd + (if (or (eq? mode 'both) + (eq? mode 'horizontal)) + (quotient (- (unbox sw) (unbox w)) 2) + (get-x)) + (if (or (eq? mode 'both) + (eq? mode 'vertical)) + (quotient (- (unbox sh) (unbox h)) 2) + (get-x)) + (unbox w) + (unbox h) + #t))) + + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child)) + (define/override (register-child-in-parent on?) + (void)) + + (define/override (get-top-frame) this) + (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index e3f085ac..27ff1cc5 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -20,7 +20,8 @@ (define gauge% (class item% - (inherit set-size) + (inherit set-size + subclass-control) (init parent label @@ -31,7 +32,7 @@ (define hwnd (CreateWindowExW 0 - "msctls_progress32" + "PLTmsctls_progress32" label (bitwise-ior WS_CHILD WS_CLIPSIBLINGS (if (memq 'vertical style) @@ -53,6 +54,8 @@ (set-size -11111 -11111 100 24) (set-size -11111 -11111 24 100)) + (subclass-control hwnd) + (define/public (get-value) (SendMessageW hwnd PBM_GETPOS 0 0)) (define/public (set-value v) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 1233d3f2..44b8fc50 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -15,17 +15,18 @@ (define group-panel% - (class (panel-mixin window%) + (class (item-mixin (panel-mixin window%)) (init parent x y w h style label) - (inherit auto-size set-control-font) + (inherit auto-size set-control-font + subclass-control) (define hwnd (CreateWindowExW 0 - "BUTTON" + "PLTBUTTON" (or label "") (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) 0 0 0 0 @@ -59,6 +60,10 @@ (lambda (w h) (set! label-h h) (set-size -11111 -11111 (+ w 10) (+ h 10)))) + (subclass-control hwnd) + + (define/public (set-label lbl) + (SetWindowTextW hwnd lbl)) (define/override (set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 6aaa3475..6abea495 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -11,17 +11,67 @@ "hbitmap.rkt" "types.rkt") -(provide item%) +(provide item-mixin + item%) -(defclass item% window% - (inherit get-hwnd) +(define (control-proc w msg wParam lParam) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx ctlproc w msg wParam lParam + (lambda (w msg wParam lParam) + (send wx default-ctlproc w msg wParam lParam))) + (send wx default-ctlproc w msg wParam lParam)))) - (super-new) +(define control_proc (function-ptr control-proc _WndProc)) - (define/override (gets-focus?) #t) +(define (item-mixin %) + (class % + (inherit on-set-focus + on-kill-focus + try-mouse) - (define/public (set-label s) - (SetWindowTextW (get-hwnd) s)) + (define old-control-procs null) + + (super-new) + + (define/public (subclass-control hwnd) + (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) + (set! old-control-procs (cons (cons hwnd old-control-proc) + old-control-procs)) + (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) + + (define/public (ctlproc w msg wParam lParam default) + (if (try-mouse w msg wParam lParam) + 0 + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + (default w msg wParam lParam)] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + (default w msg wParam lParam)] + [else + (default w msg wParam lParam)]))) + + (define/public (default-ctlproc w msg wParam lParam) + (let loop ([l old-control-procs]) + (cond + [(null? l) (error 'default-ctlproc "cannot find control in: ~e for: ~e" this w)] + [(ptr-equal? (caar l) w) + ((cdar l) w msg wParam lParam)] + [else (loop (cdr l))]))))) + +(define item% + (class (item-mixin window%) + (inherit get-hwnd) + + (super-new) + + (define/override (gets-focus?) #t) + + (define/public (set-label s) + (SetWindowTextW (get-hwnd) s)) + + (def/public-unimplemented get-label) + (def/public-unimplemented command))) - (def/public-unimplemented get-label) - (def/public-unimplemented command)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index b03def3b..c7d441c4 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -1,8 +1,10 @@ #lang racket/base (require racket/class racket/draw + (only-in racket/list take drop) ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "../common/event.rkt" "item.rkt" "utils.rkt" @@ -23,7 +25,22 @@ (define LBS_EXTENDEDSEL #x0800) (define LBS_DISABLENOSCROLL #x1000) +(define LB_ERR -1) + (define LB_ADDSTRING #x0180) +(define LB_RESETCONTENT #x0184) +(define LB_INSERTSTRING #x0181) +(define LB_DELETESTRING #x0182) +(define LB_GETTOPINDEX #x018E) +(define LB_SETTOPINDEX #x0197) +(define LB_GETITEMHEIGHT #x01A1) +(define LB_GETSELCOUNT #x0190) +(define LB_GETSELITEMS #x0191) +(define LB_GETCURSEL #x0188) +(define LB_SETSEL #x0185) +(define LB_SETCURSEL #x0186) +(define LB_GETSEL #x0187) +(define LB_SELITEMRANGE #x019B) (define list-box% (class item% @@ -32,11 +49,17 @@ choices style font label-font) - (inherit set-size set-control-font) + (inherit set-size set-control-font + subclass-control + get-client-size) + + (define single? + (and (not (memq 'extended style)) + (not (memq 'mutiple style)))) (define hwnd (CreateWindowExW WS_EX_CLIENTEDGE - "LISTBOX" + "PLTLISTBOX" label (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY WS_VSCROLL @@ -60,22 +83,99 @@ [style style]) (set-control-font font) - (set-size -11111 -11111 40 40) + (set-size -11111 -11111 40 60) - (def/public-unimplemented get-label-font) - (def/public-unimplemented set-string) - (def/public-unimplemented set-first-visible-item) - (def/public-unimplemented set) - (def/public-unimplemented get-selections) - (def/public-unimplemented get-first-item) - (def/public-unimplemented number-of-visible-items) - (def/public-unimplemented number) - (def/public-unimplemented get-selection) - (def/public-unimplemented set-data) - (def/public-unimplemented get-data) - (def/public-unimplemented selected?) - (def/public-unimplemented set-selection) - (def/public-unimplemented select) - (def/public-unimplemented delete) - (def/public-unimplemented clear) - (def/public-unimplemented append))) + (subclass-control hwnd) + + (define num (length choices)) + (define/public (number) num) + + (define data (map (lambda (x) (box #f)) choices)) + (define/public (get-data i) (unbox (list-ref data i))) + (define/public (set-data i v) (set-box! (list-ref data i) v)) + + (define/public (set-string i str) + (atomically + (SendMessageW/str hwnd LB_INSERTSTRING i str) + (SendMessageW hwnd LB_DELETESTRING (add1 i) 0))) + + (define/public (set-first-visible-item i) + (SendMessageW hwnd LB_SETTOPINDEX i 0)) + + (define/public (get-first-item) + (SendMessageW hwnd LB_GETTOPINDEX 0 0)) + + (define/public (number-of-visible-items) + (let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)]) + (let ([w (box 0)] + [h (box 0)]) + (get-client-size w h) + (quotient (unbox h) ih)))) + + (define/public (clear) + (atomically + (set! data null) + (set! num 0) + (SendMessageW hwnd LB_RESETCONTENT 0 0))) + + (define/public (set choices) + (atomically + (ShowWindow hwnd SW_HIDE) + (clear) + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + (set! data (map (lambda (s) (box #f)) choices)) + (set! num (length choices)) + (ShowWindow hwnd SW_SHOW))) + + (public [append* append]) + (define (append* s [v #f]) + (atomically + (SendMessageW/str hwnd LB_ADDSTRING 0 s) + (set! num (add1 num)) + (set! data (append data (list (box v)))))) + + (define/public (delete i) + (atomically + (set! data (append (take data i) (drop data (add1 i)))) + (set! num (sub1 num)) + (SendMessageW hwnd LB_DELETESTRING i 0))) + + (define/public (get-selections) + (atomically + (if single? + (let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)]) + (if (= v LB_ERR) + null + (list v))) + (let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)]) + (if (zero? n) + null + (let ([selections (malloc n _LONG 'raw)]) + (SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM)) + (begin0 + (for/list ([i (in-range n)]) + (ptr-ref selections _LONG i)) + (free selections)))))))) + + (define/public (get-selection) + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l)))) + + (define/public (selected? i) + (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) + + (define/public (select i [on? #t] [extend? #t]) + (if single? + (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) + (begin + (when extend? + (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) + (SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))) + + (define/public (set-selection i) + (select i #t #f)) + + (def/public-unimplemented get-label-font))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 0f6ca833..1365fdcc 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/draw + racket/promise ffi/unsafe "../../syntax.rkt" "../common/event.rkt" @@ -18,10 +19,36 @@ (define SS_LEFT #x00000000) (define SS_BITMAP #x0000000E) +(define SS_ICON #x00000003) + +(define IDI_APPLICATION 32512) +(define IDI_HAND 32513) +(define IDI_QUESTION 32514) +(define IDI_EXCLAMATION 32515) +(define IDI_WARNING IDI_EXCLAMATION) +(define IDI_ERROR IDI_HAND) + +(define IMAGE_ICON 1) + +(define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON)) + +(define app-icon + (delay + (let () + ;; GetModuleFileNameW(NULL, name, 1023); + ;; icn = ExtractIconW(NULL, name, 0); + (LoadIconW #f IDI_APPLICATION)))) +(define warning-icon + (delay + (LoadIconW #f IDI_WARNING))) +(define error-icon + (delay + (LoadIconW #f IDI_ERROR))) (define message% (class item% - (inherit auto-size set-control-font get-hwnd) + (inherit auto-size set-size set-control-font get-hwnd + subclass-control) (init parent label x y @@ -31,7 +58,7 @@ (and (label . is-a? . bitmap%) (send label ok?))) - (define/public (get-class) "STATIC") + (define/public (get-class) "PLTSTATIC") (super-new [parent parent] [hwnd @@ -43,7 +70,9 @@ (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS (if bitmap? SS_BITMAP - 0)) + (if (symbol? label) + SS_ICON + 0))) 0 0 0 0 (send parent get-client-hwnd) #f @@ -51,10 +80,21 @@ #f)] [style style]) + (subclass-control (get-hwnd)) + (when bitmap? (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) - + (when (symbol? label) + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON + (cast (force (case label + [(caution) warning-icon] + [(stop) error-icon] + [else app-icon])) + _HICON _LPARAM))) + (set-control-font font) - - (auto-size label 0 0 0 0))) + + (if (symbol? label) + (set-size -11111 -11111 32 32) + (auto-size label 0 0 0 0)))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 9ca17008..1acd02b6 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -10,8 +10,57 @@ (define (panel-mixin %) (class % + (inherit is-enabled-to-root? + reset-cursor-in-child) + (super-new) - + + (define children null) + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (unless on? + (when (eq? child mouse-in-child) + (set! mouse-in-child #f))) + (set! children + (if on? + (cons child children) + (remq child children))) + (send child parent-enable (is-enabled-to-root?))))) + + (define/override (internal-enable on?) + (super internal-enable on?) + (for ([c (in-list children)]) + (send c parent-enable on?))) + + (define mouse-in-child #f) + (define/override (generate-mouse-ins in-window mk) + (unless (eq? in-window mouse-in-child) + (when mouse-in-child + (send mouse-in-child send-leaves mk)) + (set! mouse-in-child in-window)) + (super generate-mouse-ins in-window mk)) + + (define/override (reset-cursor default) + (if mouse-in-child + (reset-cursor-in-child mouse-in-child default) + (super reset-cursor default))) + + (define/override (send-leaves mk) + (when mouse-in-child + (let ([w mouse-in-child]) + (set! mouse-in-child #f) + (send w send-leaves mk))) + (super send-leaves mk)) + + (define/override (send-child-leaves mk) + (if mouse-in-child + (let ([w mouse-in-child]) + (set! mouse-in-child #f) + (send w send-leaves mk) + #t) + #f)) + (define lbl-pos 'horizontal) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 7283e246..96878af4 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -68,6 +68,7 @@ fill-private-color cancel-quit get-control-font-size + get-control-font-size-in-pixels? get-double-click-time run-printout file-creator-and-type diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index d7eb37f5..4bfaf1fd 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -7,6 +7,7 @@ "utils.rkt" "const.rkt" "menu-item.rkt" + "frame.rkt" racket/draw) (provide @@ -26,6 +27,7 @@ run-printout get-double-click-time get-control-font-size + get-control-font-size-in-pixels? cancel-quit fill-private-color flush-display @@ -64,17 +66,12 @@ (define-unimplemented run-printout) (define (get-double-click-time) 500) (define (get-control-font-size) (get-theme-font-size)) +(define (get-control-font-size-in-pixels?) #t) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) (define-unimplemented flush-display) (define-unimplemented write-resource) (define-unimplemented get-resource) -(define (display-origin xb yb ?) - (set-box! xb 0) - (set-box! yb 0)) -(define (display-size xb yb ?) - (set-box! xb 1024) - (set-box! yb 768)) (define-unimplemented bell) (define (hide-cursor) (void)) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 901345d6..b2960250 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -112,10 +112,12 @@ (queue-message-dequeue (send wx get-eventspace) hwnd))) ;; Not our window, so dispatch any available events - (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) - (when v - (TranslateMessage msg) - (DispatchMessageW msg)))) + (let loop () + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop))))) #t)) (define check_window_event (function-ptr check-window-event _enum_proc)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 49d30a1f..0fcdfef7 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -27,7 +27,9 @@ style font) - (inherit auto-size set-control-font) + (inherit auto-size set-control-font + is-enabled-to-root? + subclass-control) (define callback cb) (define current-value val) @@ -54,7 +56,7 @@ (send label ok?))] [radio-hwnd (CreateWindowExW WS_EX_TRANSPARENT - "BUTTON" + "PLTBUTTON" (if (string? label) label "") @@ -86,6 +88,9 @@ [hwnd hwnd] [extra-hwnds radio-hwnds] [style style]) + + (for ([radio-hwnd (in-list radio-hwnds)]) + (subclass-control radio-hwnd)) (define/override (is-hwnd? a-hwnd) (or (ptr-equal? hwnd a-hwnd) @@ -121,6 +126,17 @@ (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) (set! current-value val)))) + (define buttons-enabled (make-vector (length radio-hwnds) #t)) + (define/public (enable-button i on?) + (unless (eq? (and on? #t) (vector-ref buttons-enabled i)) + (vector-set! buttons-enabled i (and on? #t)) + (when (is-enabled-to-root?) + (void (EnableWindow (list-ref radio-hwnds i) on?))))) + (define/override (internal-enable on?) + (for ([radio-hwnd (in-list radio-hwnds)] + [radio-on? (in-vector buttons-enabled)]) + (void (EnableWindow radio-hwnd (and on? radio-on?))))) + (define/public (get-selection) current-value) (define/public (number) (length radio-hwnds)))) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 8974e658..51279d65 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -29,7 +29,7 @@ (define SS_CENTER #x00000001) (define THICKNESS 24) -(define MIN_LENGTH 100) +(define MIN_LENGTH 80) (defclass slider% item% (init parent cb @@ -39,8 +39,10 @@ style font) (inherit set-control-font - auto-size) - + auto-size + subclass-control) + + (define callback cb) (define vertical? (memq 'vertical style)) (define panel-hwnd @@ -58,7 +60,7 @@ (define slider-hwnd (CreateWindowExW 0 - "msctls_trackbar32" + "PLTmsctls_trackbar32" label (bitwise-ior WS_CHILD WS_CLIPSIBLINGS (if vertical? @@ -124,6 +126,8 @@ (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) (set-value val) + (subclass-control slider-hwnd) + (define/override (set-size x y w h) (super set-size x y w h) (when panel-hwnd @@ -139,7 +143,12 @@ (define/override (control-scrolled) (when value-hwnd (let ([val (get-value)]) - (SetWindowTextW value-hwnd (format "~s" val))))) + (SetWindowTextW value-hwnd (format "~s" val)))) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)]))))) (define/public (set-value val) (SendMessageW slider-hwnd TBM_SETPOS 1 val)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 8582a056..ce62183a 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -29,7 +29,7 @@ [lParam _LPARAM])) (define tab-panel% - (class (panel-mixin window%) + (class (item-mixin (panel-mixin window%)) (init parent x y w h style @@ -41,7 +41,7 @@ (define hwnd (CreateWindowExW 0 - "SysTabControl32" + "PLTSysTabControl32" "" (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) 0 0 0 0 diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 814bea15..eff854b3 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,11 +12,15 @@ define-mz failed + GetWindowLongW + SetWindowLongW SendMessageW SendMessageW/str GetSysColor GetRValue GetGValue GetBValue MoveWindow ShowWindow - SetWindowTextW) + EnableWindow + SetWindowTextW + SetCursor) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -36,6 +40,9 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) +(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) + (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) #:c-id SendMessageW) @@ -50,7 +57,10 @@ -> (unless r (failed 'MoveWindow)))) (define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) - +(define-user32 EnableWindow (_wfun _HWND _BOOL -> _BOOL)) (define-user32 SetWindowTextW (_wfun _HWND _string/utf-16 -> (r : _BOOL) -> (unless r (failed 'SetWindowText)))) + +(define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR)) + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index b91cfe6d..1c311c2d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -2,15 +2,19 @@ (require ffi/unsafe racket/class racket/draw - "../../syntax.rkt" - "../common/freeze.rkt" - "../common/queue.rkt" - "utils.rkt" - "types.rkt" - "const.rkt" - "wndclass.rkt" - "queue.rkt" - "theme.rkt" + "../../syntax.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" + "../common/event.rkt" + "../common/local.rkt" + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "queue.rkt" + "theme.rkt" + "cursor.rkt" "key.rkt") (provide window% @@ -25,6 +29,17 @@ (define WM_PRINT #x0317) (define WM_PRINTCLIENT #x0318) +(define MK_LBUTTON #x0001) +(define MK_RBUTTON #x0002) +(define MK_SHIFT #x0004) +(define MK_CONTROL #x0008) +(define MK_MBUTTON #x0010) +(define MK_XBUTTON1 #x0020) +(define MK_XBUTTON2 #x0040) + +(define HTHSCROLL 6) +(define HTVSCROLL 7) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -37,6 +52,11 @@ (define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> (if r rect (failed 'GetClientRect)))) +(define-user32 ClientToScreen (_wfun _HWND _POINT-pointer -> (r : _BOOL) + -> (unless r (failed 'ClientToScreen)))) +(define-user32 ScreenToClient (_wfun _HWND _POINT-pointer -> (r : _BOOL) + -> (unless r (failed 'ClientToScreen)))) + (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) @@ -96,60 +116,62 @@ (ptr-equal? hwnd a-hwnd)) (define/public (wndproc w msg wParam lParam default) - (cond - [(= msg WM_SETFOCUS) - (queue-window-event this (lambda () (on-set-focus))) - 0] - [(= msg WM_KILLFOCUS) - (queue-window-event this (lambda () (on-kill-focus))) - 0] - [(= msg WM_SYSKEYDOWN) - (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key wParam lParam #f #f)))] - [(= msg WM_KEYDOWN) - (do-key wParam lParam #f #f) - 0] - [(= msg WM_KEYUP) - (do-key wParam lParam #f #t) - 0] - [(= msg WM_SYSCHAR) - (when (= wParam VK_MENU) - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key wParam lParam #t #f)))] - [(= msg WM_CHAR) - (do-key wParam lParam #t #f) - 0] - [(= msg WM_COMMAND) - (let* ([control-hwnd (cast lParam _LPARAM _HWND)] - [wx (any-hwnd->wx control-hwnd)]) - (if (and wx (send wx is-command? (HIWORD wParam))) - (begin - (send wx do-command control-hwnd) - 0) - (default w msg wParam lParam)))] - [(= msg WM_NOTIFY) - #; - (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] - [control-hwnd (NMHDR-hwndFrom nmhdr)] - [wx (any-hwnd->wx control-hwnd)]) - (when wx (send wx do-command))) - 0] - [(or (= msg WM_HSCROLL) - (= msg WM_VSCROLL)) - (let* ([control-hwnd (cast lParam _LPARAM _HWND)] - [wx (any-hwnd->wx control-hwnd)]) - (if wx - (begin - (send wx control-scrolled) - 0) - (default w msg wParam lParam)))] - [else - (default w msg wParam lParam)])) + (if (try-mouse w msg wParam lParam) + 0 + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + 0] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + 0] + [(= msg WM_SYSKEYDOWN) + (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close + (unhide-cursor) + (begin0 + (default w msg wParam lParam) + (do-key wParam lParam #f #f)))] + [(= msg WM_KEYDOWN) + (do-key wParam lParam #f #f) + 0] + [(= msg WM_KEYUP) + (do-key wParam lParam #f #t) + 0] + [(= msg WM_SYSCHAR) + (when (= wParam VK_MENU) + (unhide-cursor) + (begin0 + (default w msg wParam lParam) + (do-key wParam lParam #t #f)))] + [(= msg WM_CHAR) + (do-key wParam lParam #t #f) + 0] + [(= msg WM_COMMAND) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if (and wx (send wx is-command? (HIWORD wParam))) + (begin + (send wx do-command control-hwnd) + 0) + (default w msg wParam lParam)))] + [(= msg WM_NOTIFY) + #; + (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] + [control-hwnd (NMHDR-hwndFrom nmhdr)] + [wx (any-hwnd->wx control-hwnd)]) + (when wx (send wx do-command))) + 0] + [(or (= msg WM_HSCROLL) + (= msg WM_VSCROLL)) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if wx + (begin + (send wx control-scrolled) + 0) + (default w msg wParam lParam)))] + [else + (default w msg wParam lParam)]))) (define/public (is-command? cmd) #f) (define/public (control-scrolled) #f) @@ -160,6 +182,7 @@ (define shown? #f) (define/public (direct-show on?) (set! shown? (and on? #t)) + (register-child-in-parent on?) (unless on? (not-focus-child this)) (ShowWindow hwnd (if on? SW_SHOW SW_HIDE))) (unless (memq 'invisible style) @@ -173,12 +196,29 @@ (define/public (on-kill-focus) (void)) (define/public (get-handle) hwnd) - (define/public (is-window-enabled?) - #t) + (define enabled? #t) + (define parent-enabled? #t) + (define/public (enable on?) + (unless (eq? enabled? (and on? #t)) + (atomically + (let ([prev? (and enabled? parent-enabled?)]) + (set! enabled? (and on? #t)) + (let ([now? (and parent-enabled? enabled?)]) + (unless (eq? now? prev?) + (internal-enable now?))))))) + (define/public (parent-enable on?) + (unless (eq? on? parent-enabled?) + (let ([prev? (and enabled? parent-enabled?)]) + (set! parent-enabled? (and on? #t)) + (let ([now? (and parent-enabled? enabled?)]) + (unless (eq? prev? now?) + (internal-enable now?)))))) + (define/public (internal-enable on?) + (void (EnableWindow hwnd on?))) + (define/public (is-window-enabled?) enabled?) (define/public (is-enabled-to-root?) - (and (is-window-enabled?) - (send parent is-enabled-to-root?))) + (and enabled? parent-enabled?)) (define/public (is-shown-to-root?) (and shown? @@ -271,14 +311,23 @@ (define/public (refresh) (void)) (define/public (on-resized) (void)) - (def/public-unimplemented screen-to-client) - (def/public-unimplemented client-to-screen) + (define/public (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) + (let ([p (make-POINT (unbox x) (unbox y))]) + (ClientToScreen (get-client-hwnd) p) + (set-box! x (POINT-x p)) + (set-box! y (POINT-y p)))) (define/public (drag-accept-files on?) (void)) - (def/public-unimplemented enable) - (def/public-unimplemented get-position) + (define/public (get-position x y) + (set-box! x (get-x)) + (set-box! y (get-y))) (define/public (get-client-size w h) (let ([r (GetClientRect (get-client-hwnd))]) @@ -290,8 +339,27 @@ (set-box! w (- (RECT-right r) (RECT-left r))) (set-box! h (- (RECT-bottom r) (RECT-top r))))) - (def/public-unimplemented fit) - (def/public-unimplemented set-cursor) + (define cursor-handle #f) + (define/public (set-cursor c) + (set! cursor-handle (and c (send (send c get-driver) get-handle))) + (when mouse-in? + (cursor-updated-here))) + + (define/public (cursor-updated-here) + (when mouse-in? + (send (get-top-frame) reset-cursor (get-arrow-cursor)))) + + (define/public (reset-cursor-in-child child default) + (send child reset-cursor (or cursor-handle default))) + + (define effective-cursor-handle #f) + (define/public (reset-cursor default) + (let ([c (or cursor-handle default)]) + (set! effective-cursor-handle c) + (SetCursor c))) + + (define/public (no-cursor-handle-here) + (send parent cursor-updated-here)) (define/public (set-focus) (when (can-accept-focus?) @@ -312,6 +380,15 @@ (define/public (gets-focus?) #f) (def/public-unimplemented centre) + (define/public (register-child child on?) + (void)) + (define/public (register-child-in-parent on?) + (when parent + (send parent register-child this on?))) + + (define/public (get-top-frame) + (send parent get-top-frame)) + (define/private (do-key wParam lParam is-char? is-up?) (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) (and e @@ -323,6 +400,134 @@ (lambda () (dispatch-on-char e #t)) #t))))) + + (define/public (try-mouse w msg wParam lParam) + (cond + [(= msg WM_NCRBUTTONDOWN) + (do-mouse w #t 'right-down wParam lParam)] + [(= msg WM_NCRBUTTONUP) + (do-mouse w #t 'right-up wParam lParam)] + [(= msg WM_NCRBUTTONDBLCLK) + (do-mouse w #t 'right-down wParam lParam)] + [(= msg WM_NCMBUTTONDOWN) + (do-mouse w #t 'middle-down wParam lParam)] + [(= msg WM_NCMBUTTONUP) + (do-mouse w #t 'middle-up wParam lParam)] + [(= msg WM_NCMBUTTONDBLCLK) + (do-mouse w #t 'middle-down wParam lParam)] + [(= msg WM_NCLBUTTONDOWN) + (do-mouse w #t 'left-down wParam lParam)] + [(= msg WM_NCLBUTTONUP) + (do-mouse w #t 'left-up wParam lParam)] + [(= msg WM_NCLBUTTONDBLCLK) + (do-mouse w #t 'left-down wParam lParam)] + [(and (= msg WM_NCMOUSEMOVE) + (not (= wParam HTVSCROLL)) + (not (= wParam HTHSCROLL))) + (do-mouse w #t 'motion wParam lParam)] + [(= msg WM_RBUTTONDOWN) + (do-mouse w #f 'right-down wParam lParam)] + [(= msg WM_RBUTTONUP) + (do-mouse w #f 'right-up wParam lParam)] + [(= msg WM_RBUTTONDBLCLK) + (do-mouse w #f 'right-down wParam lParam)] + [(= msg WM_MBUTTONDOWN) + (do-mouse w #f 'middle-down wParam lParam)] + [(= msg WM_MBUTTONUP) + (do-mouse w #f 'middle-up wParam lParam)] + [(= msg WM_MBUTTONDBLCLK) + (do-mouse w #f 'middle-down wParam lParam)] + [(= msg WM_LBUTTONDOWN) + (do-mouse w #f 'left-down wParam lParam)] + [(= msg WM_LBUTTONUP) + (do-mouse w #f 'left-up wParam lParam)] + [(= msg WM_LBUTTONDBLCLK) + (do-mouse w #f 'left-down wParam lParam)] + [(= msg WM_MOUSEMOVE) + (do-mouse w #f 'motion wParam lParam)] + [(= msg WM_MOUSELEAVE) + (do-mouse w #f 'leave wParam lParam)] + [else #f])) + + (define/private (do-mouse control-hwnd nc? type wParam lParam) + (let ([x (LOWORD lParam)] + [y (HIWORD lParam)] + [flags (if nc? 0 wParam)] + [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) + (let ([make-e + (lambda (type) + (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? flags MK_LBUTTON)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? flags MK_MBUTTON)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? flags MK_RBUTTON)])] + [x x] + [y y] + [shift-down (bit? flags MK_SHIFT)] + [control-down (bit? flags MK_CONTROL)] + [meta-down #f] + [alt-down #f] + [time-stamp 0] + [caps-down #f]))]) + (if mouse-in? + (if (send-child-leaves (lambda (type) (make-e type))) + (cursor-updated-here) + (if (send (get-top-frame) is-wait-cursor-on?) + (void (SetCursor (get-wait-cursor))) + (when effective-cursor-handle + (void (SetCursor effective-cursor-handle))))) + (let ([c (generate-mouse-ins this (lambda (type) (make-e type)))]) + (when c + (set! effective-cursor-handle c) + (void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?) + (get-wait-cursor) + c)))))) + (when (memq type '(left-down right-down middle-down)) + (set-focus)) + (handle-mouse-event (make-e type))))) + + (define (handle-mouse-event e) + (if (definitely-wants-event? e) + (begin + (queue-window-event this (lambda () (dispatch-on-event/sync e))) + #t) + (constrained-reply (get-eventspace) + (lambda () (dispatch-on-event e #t)) + #t))) + + (define mouse-in? #f) + (define/public (generate-mouse-ins in-window mk) + (if mouse-in? + effective-cursor-handle + (begin + (set! mouse-in? #t) + (let ([parent-cursor (generate-parent-mouse-ins mk)]) + (handle-mouse-event (mk 'enter)) + (or cursor-handle parent-cursor))))) + + (define/public (generate-parent-mouse-ins mk) + (send parent generate-mouse-ins this mk)) + + (define/public (send-leaves mk) + (set! mouse-in? #f) + (let ([e (mk 'leave)]) + (if (eq? (current-eventspace) (get-eventspace)) + (handle-mouse-event e) + (queue-window-event this + (lambda () (dispatch-on-event/sync e)))))) + + (define/public (send-child-leaves mk) + #f) + (define/public (definitely-wants-event? e) #f) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index f446348f..30dae5f0 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -12,13 +12,11 @@ hwnd->wx any-hwnd->wx set-hwnd-wx! - MessageBoxW) + MessageBoxW + _WndProc) ;; ---------------------------------------- -(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) -(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) - (define all-cells (make-hash)) (define (hwnd->wx hwnd) @@ -95,7 +93,7 @@ 0 hInstance (LoadIconW #f IDI_APPLICATION) - (LoadCursorW #f IDC_ARROW) + #f (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) (cpointer-push-tag! p 'HBRUSH) p) @@ -108,7 +106,7 @@ 0 hInstance #f - (LoadCursorW #f IDC_ARROW) + #f (let ([p (ptr-add #f (+ COLOR_WINDOW 1))]) (cpointer-push-tag! p 'HBRUSH) p) @@ -121,7 +119,7 @@ 0 hInstance #f - (LoadCursorW #f IDC_ARROW) + #f (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) (cpointer-push-tag! p 'HBRUSH) p) @@ -136,7 +134,7 @@ 0 hInstance #f - (LoadCursorW #f IDC_ARROW) + #f (if controls-are-transparent? #f ; transparent (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) @@ -146,3 +144,17 @@ "PLTTabPanel"))) (define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int)) + +(define (register-no-cursor orig-name) + (let ([i (GetClassInfoW hInstance orig-name)]) + (set-WNDCLASS-lpszClassName! i (string-append "PLT" orig-name)) + (set-WNDCLASS-hCursor! i #f) + (void (RegisterClassW i)))) + +(register-no-cursor "BUTTON") +(register-no-cursor "STATIC") +(register-no-cursor "LISTBOX") +(register-no-cursor "COMBOBOX") +(register-no-cursor "msctls_trackbar32") +(register-no-cursor "msctls_progress32") +(register-no-cursor "SysTabControl32") diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index e8bd6f9a..cff8412a 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -6,7 +6,7 @@ (define my-txt #f) (define my-lb #f) -(define noisy? #f) +(define noisy? #t) (define mdi-frame #f) (define (mdi) From 8c385a23bf51cc29e996aded374974bdeaad425c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 30 Sep 2010 21:31:53 -0600 Subject: [PATCH 247/462] gtk: try fullscreen original commit: 1dd3c8accbc07ad97fbbcd4a961d67da5902b167 --- collects/mred/private/wx/gtk/frame.rkt | 4 ++++ collects/scribblings/gui/frame-class.scrbl | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 7cf3642d..3077daae 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -45,6 +45,7 @@ -> (values x y))) (define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) (define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void)) +(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void)) (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) @@ -163,6 +164,9 @@ (set-size x y w h) + (when (memq 'hide-menu-bar style) + (gtk_window_fullscreen gtk)) + (connect-delete gtk) (connect-configure gtk) diff --git a/collects/scribblings/gui/frame-class.scrbl b/collects/scribblings/gui/frame-class.scrbl index 927307c6..7fac78e1 100644 --- a/collects/scribblings/gui/frame-class.scrbl +++ b/collects/scribblings/gui/frame-class.scrbl @@ -87,7 +87,8 @@ some platforms: frame's title bar (Mac OS X); a click on the toolbar button triggers a call to @method[frame% on-toolbar-button-click]} @item{@scheme['hide-menu-bar] --- hides the menu bar and dock when - the frame is active (Mac OS X)} + the frame is active (Mac OS X) or asks the window manager to make + the frame fullscreen (X)} @item{@scheme['float] --- causes the frame to stay in front of all other non-floating windows (Windows and Mac OS X always, X when From 428cf1577e43d0cb69a3ba97c2a3c00ef6390ebb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 1 Oct 2010 19:26:30 -0600 Subject: [PATCH 248/462] win32: more menus and controls original commit: 912a2d515170698d61137dc9eecb25712065ff5e --- collects/mred/private/wx/common/dialog.rkt | 49 ++++++++++ collects/mred/private/wx/gtk/dialog.rkt | 72 ++++----------- collects/mred/private/wx/gtk/window.rkt | 14 +-- collects/mred/private/wx/win32/button.rkt | 3 +- collects/mred/private/wx/win32/canvas.rkt | 3 - collects/mred/private/wx/win32/choice.rkt | 3 +- collects/mred/private/wx/win32/const.rkt | 4 + collects/mred/private/wx/win32/dc.rkt | 3 - collects/mred/private/wx/win32/dialog.rkt | 28 +----- collects/mred/private/wx/win32/frame.rkt | 73 ++++++++++++--- collects/mred/private/wx/win32/gauge.rkt | 3 +- .../mred/private/wx/win32/group-panel.rkt | 3 +- collects/mred/private/wx/win32/hbitmap.rkt | 2 - collects/mred/private/wx/win32/item.rkt | 13 ++- collects/mred/private/wx/win32/key.rkt | 4 +- collects/mred/private/wx/win32/list-box.rkt | 3 +- collects/mred/private/wx/win32/menu-bar.rkt | 7 +- collects/mred/private/wx/win32/menu-item.rkt | 35 ++++++- collects/mred/private/wx/win32/menu.rkt | 51 ++++++++--- collects/mred/private/wx/win32/message.rkt | 3 +- collects/mred/private/wx/win32/procs.rkt | 8 +- collects/mred/private/wx/win32/radio-box.rkt | 20 +++- collects/mred/private/wx/win32/slider.rkt | 3 +- collects/mred/private/wx/win32/tab-panel.rkt | 91 ++++++++++++++++--- collects/mred/private/wx/win32/types.rkt | 4 + collects/mred/private/wx/win32/utils.rkt | 10 +- collects/mred/private/wx/win32/window.rkt | 48 +++++----- 27 files changed, 386 insertions(+), 174 deletions(-) create mode 100644 collects/mred/private/wx/common/dialog.rkt diff --git a/collects/mred/private/wx/common/dialog.rkt b/collects/mred/private/wx/common/dialog.rkt new file mode 100644 index 00000000..a1aa765f --- /dev/null +++ b/collects/mred/private/wx/common/dialog.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require racket/class + "../../lock.rkt" + "queue.rkt") + +(provide dialog-mixin) + +(define dialog-level-counter 0) + +(define (dialog-mixin %) + (class % + (super-new) + + (define close-sema #f) + + (define dialog-level 0) + (define/override (get-dialog-level) dialog-level) + + (define/override (frame-relative-dialog-status win) + (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))) + + (define/override (direct-show on?) + ;; atomic mode + (when on? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (unless on? + (set! dialog-level 0)) + (unless on? + (atomically + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f)))) + (super direct-show on?)) + + (define/override (show on?) + (if on? + (let ([s (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + (semaphore-peek-evt s)))]) + (super show on?) + (yield s) + (void)) + (super show on?))))) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 6c063d65..04477ac8 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -3,6 +3,7 @@ ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" + "../common/dialog.rkt" "../../lock.rkt" "types.rkt" "utils.rkt" @@ -19,60 +20,23 @@ (define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) -(define dialog-level-counter 0) +(define dialog% + (class (dialog-mixin frame%) + (inherit get-gtk + get-parent) -(defclass dialog% frame% - (inherit get-gtk - get-parent) + (super-new [is-dialog? #t]) - (super-new [is-dialog? #t]) + (gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG) - (define close-sema #f) - - (gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG) - - (let ([p (get-parent)]) - (when p - (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) - - (define dialog-level 0) - (define/override (get-dialog-level) dialog-level) - - (define/override (frame-relative-dialog-status win) - (let ([dl (send win get-dialog-level)]) - (cond - [(= dl dialog-level) 'same] - [(dl . > . dialog-level) #f] - [else 'other]))) - - (define/override (direct-show on?) - (when on? - (set! dialog-level-counter (add1 dialog-level-counter)) - (set! dialog-level dialog-level-counter)) - (unless on? - (set! dialog-level 0)) - (unless on? - (atomically - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f)))) - (super direct-show on?)) - - (define/override (center dir wrt) - (if (eq? dir 'both) - (gtk_window_set_position (get-gtk) - (if (get-parent) - GTK_WIN_POS_CENTER_ON_PARENT - GTK_WIN_POS_CENTER)) - (super center dir wrt))) - - (define/override (show on?) - (if on? - (let ([s (atomically - (let ([s (or close-sema (make-semaphore))]) - (unless close-sema (set! close-sema s)) - (semaphore-peek-evt s)))]) - (super show on?) - (yield s) - (void)) - (super show on?)))) + (let ([p (get-parent)]) + (when p + (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) + + (define/override (center dir wrt) + (if (eq? dir 'both) + (gtk_window_set_position (get-gtk) + (if (get-parent) + GTK_WIN_POS_CENTER_ON_PARENT + GTK_WIN_POS_CENTER)) + (super center dir wrt))))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 30738906..85a05333 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -475,15 +475,15 @@ (define shown? #f) (define/public (direct-show on?) - (atomically - (if on? - (gtk_widget_show gtk) - (gtk_widget_hide gtk)) - (set! shown? (and on? #t)) - (register-child-in-parent on?)) + (if on? + (gtk_widget_show gtk) + (gtk_widget_hide gtk)) + (set! shown? (and on? #t)) + (register-child-in-parent on?) (when on? (reset-child-dcs))) (define/public (show on?) - (direct-show on?)) + (atomically + (direct-show on?))) (define/public (reset-child-dcs) (void)) (define/public (is-shown?) shown?) (define/public (is-shown-to-root?) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 85e40db4..80901867 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -33,7 +33,8 @@ (define/public (get-class) "PLTBUTTON") (define/public (get-flags) BS_PUSHBUTTON) - (super-new [parent parent] + (super-new [callback cb] + [parent parent] [hwnd (CreateWindowExW 0 (get-class) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 0fd6d312..077e97e5 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -18,11 +18,8 @@ (provide canvas%) -(define-user32 GetDC (_wfun _HWND -> _HDC)) (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) -(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) - -> (unless r (failed 'InvalidateRect)))) (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) -> (unless r (failed 'ShowScrollbar)))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 7b0a5480..383c9998 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -51,7 +51,8 @@ (SendMessageW hwnd CB_SETCURSEL 0 0) - (super-new [parent parent] + (super-new [callback cb] + [parent parent] [hwnd hwnd] [style style]) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 2e56a8d7..6f2e9e6d 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -598,3 +598,7 @@ (define SW_SHOW 5) (define SW_HIDE 0) + +(define HORZRES 8) +(define VERTRES 10) + diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 2ddc3c95..3fd63e7d 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -17,9 +17,6 @@ request-flush-delay cancel-flush-delay) -(define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) - (define win32-bitmap% (class bitmap% (init w h hwnd) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index 6456686a..3a5537d6 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -6,6 +6,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" + "../common/dialog.rkt" "utils.ss" "const.ss" "types.ss" @@ -50,13 +51,11 @@ (define dialog-proc (function-ptr dlgproc _DialogProc)) -(define dialog-level-counter 0) - (define dialog% - (class frame% + (class (dialog-mixin frame%) (super-new) - (define/override (create-frame parent label w h) + (define/override (create-frame parent label w h style) (let ([hwnd (CreateDialogIndirectParamW hInstance (make-DLGTEMPLATE @@ -70,23 +69,4 @@ (MoveWindow hwnd 0 0 w h #t) hwnd)) - (define/override (is-dialog?) #t) - - (define dialog-level 0) - (define/override (get-dialog-level) dialog-level) - - (define/override (frame-relative-dialog-status win) - (let ([dl (send win get-dialog-level)]) - (cond - [(= dl dialog-level) 'same] - [(dl . > . dialog-level) #f] - [else 'other]))) - - (define/override (direct-show on?) - (when on? - (set! dialog-level-counter (add1 dialog-level-counter)) - (set! dialog-level dialog-level-counter)) - (unless on? - (set! dialog-level 0)) - (super direct-show on?)))) - + (define/override (is-dialog?) #t))) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 7154f107..ff250eb5 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -22,14 +22,38 @@ (define-user32 GetActiveWindow (_wfun -> _HWND)) (define-user32 SetFocus (_wfun _HWND -> _HWND)) +(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) + +(define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL) + -> (unless r (failed 'SystemParametersInfo)))) + +(define SPI_GETWORKAREA #x0030) + +(define (display-size xb yb ?) + (atomically + (let ([hdc (GetDC #f)]) + (set-box! xb (GetDeviceCaps hdc HORZRES)) + (set-box! yb (GetDeviceCaps hdc VERTRES)) + (ReleaseDC #f hdc)))) + +(define (display-origin xb yb avoid-bars?) + (if avoid-bars? + (let ([r (make-RECT 0 0 0 0)]) + (SystemParametersInfoW SPI_GETWORKAREA 0 r 0) + (set-box! xb (RECT-left r)) + (set-box! yb (RECT-top r))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + (define mouse-frame #f) -(define (display-origin xb yb ?) - (set-box! xb 0) - (set-box! yb 0)) -(define (display-size xb yb ?) - (set-box! xb 1024) - (set-box! yb 768)) +(define WS_EX_TOOLWINDOW #x00000080) +(define WS_EX_TOPMOST #x00000008) +(define WS_EX_WINDOWEDGE #x00000100) +(define WS_EX_PALETTEWINDOW (bitwise-ior WS_EX_WINDOWEDGE + WS_EX_TOOLWINDOW + WS_EX_TOPMOST)) (defclass frame% window% (init parent @@ -46,11 +70,29 @@ pre-on-char pre-on-event reset-cursor-in-child) - (define/public (create-frame parent label w h) - (CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED) + (define/public (create-frame parent label w h style) + (CreateWindowExW (if (memq 'float style) + (bitwise-ior WS_EX_TOOLWINDOW + (if (memq 'no-caption style) + WS_EX_TOPMOST + WS_EX_PALETTEWINDOW)) + 0) "PLTFrame" (if label label "") - WS_OVERLAPPEDWINDOW + (bitwise-ior + WS_POPUP + (if (memq 'no-resize-border style) + 0 + (bitwise-ior WS_THICKFRAME + WS_BORDER + WS_MAXIMIZEBOX)) + (if (memq 'no-system-menu style) + 0 + WS_SYSMENU) + (if (memq 'no-caption style) + 0 + (bitwise-ior WS_CAPTION + WS_MINIMIZEBOX))) 0 0 w h #f #f @@ -58,7 +100,7 @@ #f)) (super-new [parent #f] - [hwnd (create-frame parent label w h)] + [hwnd (create-frame parent label w h style)] [style (cons 'invisible style)]) (define hwnd (get-hwnd)) @@ -79,6 +121,7 @@ (super show on?)) (define/override (direct-show on?) + ;; atomic mode (when (eq? mouse-frame this) (set! mouse-frame #f)) (register-frame-shown this on?) (super direct-show on?)) @@ -154,7 +197,7 @@ (define/private (set-frame-focus) (when focus-window-path - (SetFocus (send (last focus-window-path) get-hwnd)))) + (SetFocus (send (last focus-window-path) get-focus-hwnd)))) (define/override (child-can-accept-focus?) #t) @@ -246,6 +289,10 @@ (define/override (is-frame?) #t) - (def/public-unimplemented set-icon) + (define/public (set-icon bm mask [mode 'both]) + (void)) + (def/public-unimplemented iconize) - (def/public-unimplemented set-title)) + (define/public (set-title s) + (SetWindowTextW (get-hwnd) s))) + diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index 27ff1cc5..a2799cd8 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -44,7 +44,8 @@ hInstance #f)) - (super-new [parent parent] + (super-new [callback void] + [parent parent] [hwnd hwnd] [style style]) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 44b8fc50..8fe5c030 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -46,7 +46,8 @@ hInstance #f)) - (super-new [parent parent] + (super-new [callback void] + [parent parent] [hwnd hwnd] [style style]) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index b8d7caf6..7458c8db 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -15,8 +15,6 @@ (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) -> (unless r (failed 'DeleteDC)))) (define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP)) -(define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) (define (bitmap->hbitmap bm) (let* ([w (send bm get-width)] diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 6abea495..c4f93ee7 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -28,7 +28,12 @@ (class % (inherit on-set-focus on-kill-focus - try-mouse) + try-mouse + wndproc) + + (init-field [callback void]) + (define/public (command e) + (callback this e)) (define old-control-procs null) @@ -51,7 +56,7 @@ (queue-window-event this (lambda () (on-kill-focus))) (default w msg wParam lParam)] [else - (default w msg wParam lParam)]))) + (wndproc w msg wParam lParam default)]))) (define/public (default-ctlproc w msg wParam lParam) (let loop ([l old-control-procs]) @@ -72,6 +77,6 @@ (define/public (set-label s) (SetWindowTextW (get-hwnd) s)) - (def/public-unimplemented get-label) - (def/public-unimplemented command))) + (def/public-unimplemented get-label))) + diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index b56ecdf0..154c65d9 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -217,7 +217,9 @@ [e (new key-event% [key-code (if is-up? 'release - id)] + (if (equal? id #\033) + 'escape + id))] [shift-down shift-down?] [control-down control-down?] [meta-down #f] diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index c7d441c4..20a57602 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -78,7 +78,8 @@ (for ([s (in-list choices)]) (SendMessageW/str hwnd LB_ADDSTRING 0 s)) - (super-new [parent parent] + (super-new [callback cb] + [parent parent] [hwnd hwnd] [style style]) diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 33df806d..3e1ea073 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -23,10 +23,13 @@ (define menus null) - (def/public-unimplemented set-label-top) + (define/public (set-label-top pos str) + (void)) ;; FIXME + (def/public-unimplemented number) (def/public-unimplemented enable-top) - (def/public-unimplemented delete) + (define/public (delete which pos) + (void)) ;; FIXME (public [append-item append]) (define (append-item m lbl) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 57e57e7e..daa901de 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -1,6 +1,9 @@ #lang scheme/base (require ffi/unsafe scheme/class + "utils.rkt" + "types.rkt" + "const.rkt" "../../syntax.rkt") (provide menu-item% @@ -14,6 +17,12 @@ (let ([wb (hash-ref ids id #f)]) (and wb (weak-box-value wb)))) +(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT)) +(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD)) +(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16 + -> (r : _BOOL) + -> (unless r (failed 'ModifyMenuW)))) + (defclass menu-item% object% (define id @@ -30,13 +39,37 @@ (define parent #f) (define label #f) (define checkable? #f) + (define submenu #f) - (define/public (set-parent p lbl chkbl?) + (define/public (set-parent p lbl chkbl? subm) (set! parent p) (set! label lbl) (set! checkable? chkbl?) id) + (define/public (set-label hmenu pos str) + (if submenu + (ModifyMenuW hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP) + (cast (send submenu get-hmenu) _HMENU _UINT_PTR) + str) + (ModifyMenuW hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING + (GetMenuState hmenu pos MF_BYPOSITION)) + id + str))) + + (define/public (set-check hmenu pos on?) + (void + (CheckMenuItem hmenu pos (bitwise-ior MF_BYPOSITION + (if on? + MF_CHECKED + MF_UNCHECKED))))) + + (define/public (get-check hmenu pos) + (let ([s (GetMenuState hmenu pos MF_BYPOSITION)]) + (not (zero? (bitwise-and s MF_CHECKED))))) + (public [get-id id]) (define (get-id) id) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 4991ab20..5ed3cec0 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -38,28 +38,57 @@ (def/public-unimplemented get-font) (def/public-unimplemented set-width) (def/public-unimplemented set-title) - (def/public-unimplemented set-label) + + (define/private (with-item id proc) + (let loop ([items items] [pos 0]) + (cond + [(null? items) (void)] + [(and (car items) + (eq? id (send (car items) id))) + (proc (car items) pos)] + [else (loop (cdr items) (add1 pos))]))) + + (define/public (set-label id str) + (with-item + id + (lambda (i pos) + (send i set-label hmenu pos str)))) + (def/public-unimplemented set-help-string) (def/public-unimplemented number) (define/public (enable id on?) - (for ([i (in-list items)] - [pos (in-naturals)]) - (when (and i (eq? id (send i id))) - (void - (EnableMenuItem hmenu pos (bitwise-ior MF_BYPOSITION - (if on? MF_ENABLED MF_GRAYED))))))) + (with-item + id + (lambda (i pos) + (void + (EnableMenuItem hmenu pos + (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED))))))) + + (define/public (check id on?) + (with-item + id + (lambda (i pos) + (send i set-check hmenu pos on?)))) + + (define/public (checked? id) + (with-item + id + (lambda (i pos) + (send i get-check hmenu pos)))) - (def/public-unimplemented check) - (def/public-unimplemented checked?) (def/public-unimplemented delete-by-position) - (def/public-unimplemented delete) + (define/public (delete id) + (void)) (public [append-item append]) (define (append-item id label help-str-or-submenu chckable?) (let ([i (id-to-menu-item id)]) (when i - (let ([id (send i set-parent this label chckable?)]) + (let ([id (send i set-parent this label chckable? + (and (help-str-or-submenu . is-a? . menu%) + help-str-or-submenu))]) (atomically (set! items (append items (list i))) (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 1365fdcc..a72d0027 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -60,7 +60,8 @@ (define/public (get-class) "PLTSTATIC") - (super-new [parent parent] + (super-new [callback void] + [parent parent] [hwnd (CreateWindowExW (if (string? label) WS_EX_TRANSPARENT 0) (get-class) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 4bfaf1fd..958cad7d 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -57,7 +57,7 @@ (define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) -(define-unimplemented register-collecting-blit) +(define (register-collecting-blit . args) (void)) (define-unimplemented unregister-collecting-blit) (define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) @@ -69,7 +69,7 @@ (define (get-control-font-size-in-pixels?) #t) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) -(define-unimplemented flush-display) +(define (flush-display) (void)) (define-unimplemented write-resource) (define-unimplemented get-resource) (define-unimplemented bell) @@ -79,13 +79,13 @@ (define-unimplemented end-busy-cursor) (define-unimplemented is-busy?) (define-unimplemented begin-busy-cursor) -(define-unimplemented get-display-depth) +(define (get-display-depth) 32) (define-unimplemented is-color-display?) (define-unimplemented file-selector) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) -(define-unimplemented can-show-print-setup?) +(define (can-show-print-setup?) #f) (define (get-highlight-background-color) (let ([c (GetSysColor COLOR_HIGHLIGHT)]) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 0fcdfef7..583b246e 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -29,7 +29,8 @@ (inherit auto-size set-control-font is-enabled-to-root? - subclass-control) + subclass-control + set-focus) (define callback cb) (define current-value val) @@ -84,7 +85,8 @@ (unless (= val -1) (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) - (super-new [parent parent] + (super-new [callback cb] + [parent parent] [hwnd hwnd] [extra-hwnds radio-hwnds] [style style]) @@ -115,7 +117,19 @@ [time-stamp (current-milliseconds)]))))))) - (def/public-unimplemented button-focus) + (define focused 0) + + (define/public (button-focus i) + (if (= i -1) + (min focused (length radio-hwnds)) + (begin + (set! focused i) + (set-focus (list-ref radio-hwnds i))))) + + (define/override (get-focus-hwnd) + (if (= focused -1) + hwnd + (list-ref radio-hwnds focused))) (define/public (set-selection val) (atomically diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 51279d65..320e530f 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -90,7 +90,8 @@ (define hwnd (or panel-hwnd slider-hwnd)) - (super-new [parent parent] + (super-new [callback cb] + [parent parent] [hwnd hwnd] [extra-hwnds (if panel-hwnd diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index ce62183a..16b709df 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -18,6 +18,12 @@ (define TCM_SETUNICODEFORMAT #x2005) (define TCM_FIRST #x1300) (define TCM_INSERTITEMW (+ TCM_FIRST 62)) +(define TCM_SETITEMW (+ TCM_FIRST 61)) +(define TCM_SETCURSEL (+ TCM_FIRST 12)) +(define TCM_GETCURSEL (+ TCM_FIRST 11)) +(define TCM_GETITEMCOUNT (+ TCM_FIRST 4)) +(define TCM_DELETEITEM (+ TCM_FIRST 8)) +(define TCM_DELETEALLITEMS (+ TCM_FIRST 9)) (define-cstruct _TCITEMW ([mask _UINT] @@ -37,7 +43,8 @@ (define callback void) - (inherit auto-size set-control-font) + (inherit auto-size set-control-font + is-shown-to-root?) (define hwnd (CreateWindowExW 0 @@ -61,7 +68,9 @@ hInstance #f)) - (super-new [parent parent] + (super-new [callback (lambda (c) (callback c))] + [extra-hwnds (list client-hwnd)] + [parent parent] [hwnd hwnd] [style style]) @@ -70,15 +79,17 @@ (SendMessageW hwnd TCM_SETUNICODEFORMAT 1 0) - (atomically - (let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)]) - (set-TCITEMW-mask! item TCIF_TEXT) - (for ([i (in-list choices)] - [pos (in-naturals)]) - (set-TCITEMW-pszText! item i) - (SendMessageW hwnd TCM_INSERTITEMW pos (cast item _pointer _LPARAM)) - (free (TCITEMW-pszText item))) - (free item))) + (define/private (with-item proc) + (atomically + (let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)]) + (set-TCITEMW-mask! item TCIF_TEXT) + (proc item + (lambda () (free (TCITEMW-pszText item))) + (lambda (msg w) + (SendMessageW hwnd msg w (cast item _pointer _LPARAM)))) + (free item)))) + + (set choices) (define tab-height 0) @@ -95,6 +106,64 @@ (unless (or (= w -1) (= h -1)) (MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t))) + (define/override (is-command? cmd) + (= cmd 64985)) + + (define/public (do-command control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))))) + + ;; Needed after some actions: + (define/private (refresh) + (InvalidateRect hwnd #f #f)) + + (define/public (set-label pos str) + (with-item + (lambda (item done-str send-msg) + (set-TCITEMW-pszText! item str) + (send-msg TCM_SETITEMW pos) + (done-str))) + (refresh)) + + (define/public (set-selection pos) + (SendMessageW hwnd TCM_SETCURSEL pos 0) + (refresh)) + + (define/public (get-selection) + (SendMessageW hwnd TCM_GETCURSEL 0 0)) + + (define/public (number) + (SendMessageW hwnd TCM_GETITEMCOUNT 0 0)) + + (define/public (delete pos) + (SendMessageW hwnd TCM_DELETEITEM pos 0) + (refresh)) + + (public [append* append]) + (define (append* str) + (with-item + (lambda (item done-str send-msg) + (set-TCITEMW-pszText! item str) + (send-msg TCM_INSERTITEMW (number)) + (done-str))) + (refresh)) + + (define/public (set choices) + (let ([sel (get-selection)]) + (SendMessageW hwnd TCM_DELETEALLITEMS 0 0) + (with-item + (lambda (item done-str send-msg) + (for ([str (in-list choices)] + [pos (in-naturals)]) + (set-TCITEMW-pszText! item str) + (send-msg TCM_INSERTITEMW pos) + (done-str)))) + (let ([sel (max 0 (min (length choices) sel))]) + (set-selection sel)))) + (define/public (set-callback cb) (set! callback cb)))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 0c41a48a..26856830 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -4,12 +4,14 @@ (provide _wfun _DWORD + _UDWORD _ATOM _WPARAM _LPARAM _LRESULT _BOOL _UINT + _UINT_PTR _BYTE _LONG _SHORT @@ -45,12 +47,14 @@ (_fun #:abi 'stdcall . a)) (define _DWORD _int32) +(define _UDWORD _uint32) (define _ATOM _int) (define _WPARAM _long) (define _LPARAM _long) (define _LRESULT _long) (define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) (define _UINT _uint) +(define _UINT_PTR _ulong) (define _BYTE _uint8) (define _HRESULT _int32) (define _WCHAR _int16) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index eff854b3..2c10cf68 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -20,7 +20,10 @@ ShowWindow EnableWindow SetWindowTextW - SetCursor) + SetCursor + GetDC + ReleaseDC + InvalidateRect) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -64,3 +67,8 @@ (define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR)) +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) + +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) + -> (unless r (failed 'InvalidateRect)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 1c311c2d..2c381f8d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -43,7 +43,7 @@ (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 - _DWORD + _UDWORD _int _int _int _int _HWND _HMENU _HINSTANCE _pointer -> _HWND)) @@ -92,8 +92,6 @@ (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) -(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) - -> (unless r (failed 'InvalidateRect)))) (defclass window% object% (init-field parent hwnd) @@ -110,6 +108,7 @@ (define/public (get-hwnd) hwnd) (define/public (get-client-hwnd) hwnd) + (define/public (get-focus-hwnd) hwnd) (define/public (get-eventspace) eventspace) (define/public (is-hwnd? a-hwnd) @@ -125,24 +124,24 @@ [(= msg WM_KILLFOCUS) (queue-window-event this (lambda () (on-kill-focus))) 0] - [(= msg WM_SYSKEYDOWN) - (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key wParam lParam #f #f)))] + [(and (= msg WM_SYSKEYDOWN) + (or (= wParam VK_MENU) (= wParam VK_F4))) ;; F4 is close + (unhide-cursor) + (begin0 + (default w msg wParam lParam) + (do-key wParam lParam #f #f))] [(= msg WM_KEYDOWN) (do-key wParam lParam #f #f) 0] [(= msg WM_KEYUP) (do-key wParam lParam #f #t) 0] - [(= msg WM_SYSCHAR) - (when (= wParam VK_MENU) - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key wParam lParam #t #f)))] + [(and (= msg WM_SYSCHAR) + (= wParam VK_MENU)) + (unhide-cursor) + (begin0 + (default w msg wParam lParam) + (do-key wParam lParam #t #f))] [(= msg WM_CHAR) (do-key wParam lParam #t #f) 0] @@ -155,12 +154,14 @@ 0) (default w msg wParam lParam)))] [(= msg WM_NOTIFY) - #; (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] - [control-hwnd (NMHDR-hwndFrom nmhdr)] - [wx (any-hwnd->wx control-hwnd)]) - (when wx (send wx do-command))) - 0] + [control-hwnd (NMHDR-hwndFrom nmhdr)] + [wx (any-hwnd->wx control-hwnd)]) + (if (and wx (send wx is-command? (LOWORD (NMHDR-code nmhdr)))) + (begin + (send wx do-command control-hwnd) + 0) + (default w msg wParam lParam)))] [(or (= msg WM_HSCROLL) (= msg WM_VSCROLL)) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] @@ -177,10 +178,11 @@ (define/public (control-scrolled) #f) (define/public (show on?) - (direct-show on?)) + (atomically (direct-show on?))) (define shown? #f) (define/public (direct-show on?) + ;; atomic mode (set! shown? (and on? #t)) (register-child-in-parent on?) (unless on? (not-focus-child this)) @@ -361,9 +363,9 @@ (define/public (no-cursor-handle-here) (send parent cursor-updated-here)) - (define/public (set-focus) + (define/public (set-focus [child-hwnd hwnd]) (when (can-accept-focus?) - (set-top-focus this null hwnd))) + (set-top-focus this null child-hwnd))) (define/public (can-accept-focus?) (child-can-accept-focus?)) From 536cf6582b80a57eb1154ed8e982d406226664cc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 1 Oct 2010 20:12:22 -0600 Subject: [PATCH 249/462] win32: more menus and widgets original commit: 70b26a58855d66ee521171005189bc23f8b1e0fd --- collects/mred/private/wx/win32/canvas.rkt | 5 ++- collects/mred/private/wx/win32/choice.rkt | 22 ++++++++-- collects/mred/private/wx/win32/const.rkt | 10 +++++ collects/mred/private/wx/win32/frame.rkt | 45 +++++++++++++++++--- collects/mred/private/wx/win32/menu-bar.rkt | 26 ++++++++--- collects/mred/private/wx/win32/menu-item.rkt | 6 --- collects/mred/private/wx/win32/menu.rkt | 15 ++++++- collects/mred/private/wx/win32/slider.rkt | 10 +++-- collects/mred/private/wx/win32/types.rkt | 3 +- collects/mred/private/wx/win32/utils.rkt | 14 +++++- collects/mred/private/wx/win32/window.rkt | 4 +- collects/tests/gracket/item.rkt | 2 +- 12 files changed, 131 insertions(+), 31 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 077e97e5..2a3f998e 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -254,4 +254,7 @@ (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) (def/public-unimplemented view-start) - (def/public-unimplemented set-resize-corner)))) + + (define/public (set-resize-corner on?) + (void))))) + diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 383c9998..c71cdcbb 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -3,6 +3,7 @@ racket/draw ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "../common/event.rkt" "item.rkt" "utils.rkt" @@ -18,6 +19,8 @@ (define CB_SETCURSEL #x014E) (define CB_GETCURSEL #x0147) (define CBN_SELENDOK 9) +(define CB_ADDSTRING #x0143) +(define CB_RESETCONTENT #x014B) (define choice% (class item% @@ -59,7 +62,8 @@ (set-control-font font) ;; setting the choice height somehow sets the ;; popup-menu size, not the control that you see - (auto-size choices 0 0 40 0 + (auto-size (if (null? choices) (list "Choice") choices) + 0 0 40 0 (lambda (w h) (set-size -11111 -11111 w (* h 8)))) @@ -85,6 +89,18 @@ (define/public (number) num-choices) - (def/public-unimplemented clear) - (def/public-unimplemented append))) + (define/public (clear) + (atomically + (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)))))) + + diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 6f2e9e6d..cfc0bd73 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -598,6 +598,16 @@ (define SW_SHOW 5) (define SW_HIDE 0) +(define SW_SHOWNORMAL 1) +(define SW_SHOWMINIMIZED 2) +(define SW_SHOWMAXIMIZED 3) +(define SW_MAXIMIZE 3) +(define SW_SHOWNOACTIVATE 4) +(define SW_MINIMIZE 6) +(define SW_SHOWMINNOACTIVE 7) +(define SW_RESTORE 9) +(define SW_SHOWDEFAULT 10) +(define SW_FORCEMINIMIZE 11) (define HORZRES 8) (define VERTRES 10) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index ff250eb5..87bf4e93 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -24,9 +24,15 @@ (define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) +(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DrawMenuBar)))) + +(define-user32 IsZoomed (_wfun _HWND -> _BOOL)) + (define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL) -> (unless r (failed 'SystemParametersInfo)))) + (define SPI_GETWORKAREA #x0030) (define (display-size xb yb ?) @@ -99,6 +105,9 @@ hInstance #f)) + (define saved-title (or label "")) + (define hidden-zoomed? #f) + (super-new [parent #f] [hwnd (create-frame parent label w h style)] [style (cons 'invisible style)]) @@ -124,7 +133,11 @@ ;; atomic mode (when (eq? mouse-frame this) (set! mouse-frame #f)) (register-frame-shown this on?) - (super direct-show on?)) + (when (and (not on?) (is-shown?)) + (set! hidden-zoomed? (is-maximized?))) + (super direct-show on? (if hidden-zoomed? + SW_SHOWMAXIMIZED + SW_SHOW))) (define/private (stdret f d) (if (is-dialog?) d f)) @@ -275,9 +288,25 @@ (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) - (def/public-unimplemented set-modified) - (def/public-unimplemented is-maximized?) - (def/public-unimplemented maximize) + + (define modified? #f) + (define/public (set-modified on?) + (unless (eq? modified? (and on? #t)) + (set! modified? (and on? #t)) + (set-title saved-title))) + + (define/public (is-maximized?) + (if (is-shown?) + hidden-zoomed? + (IsZoomed hwnd))) + + (define/public (maximize on?) + (if (is-shown?) + (set! hidden-zoomed? (and on? #t)) + (ShowWindow hwnd (if on? + SW_MAXIMIZE + SW_RESTORE)))) + (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) @@ -286,6 +315,9 @@ (atomically (set! menu-bar mb) (send mb set-parent this))) + + (define/public (draw-menu-bar) + (DrawMenuBar hwnd)) (define/override (is-frame?) #t) @@ -294,5 +326,8 @@ (def/public-unimplemented iconize) (define/public (set-title s) - (SetWindowTextW (get-hwnd) s))) + (atomically + (set! saved-title s) + (SetWindowTextW (get-hwnd) (string-append s (if modified? "*" "")))))) + diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 3e1ea073..86a389c3 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -1,5 +1,6 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + (only-in racket/list take drop) ffi/unsafe "../../lock.rkt" "../../syntax.rkt" @@ -22,22 +23,35 @@ (define hmenu (CreateMenu)) (define menus null) + (define parent #f) (define/public (set-label-top pos str) - (void)) ;; FIXME + (send (list-ref menus pos) set-menu-label hmenu pos str) + (refresh)) (def/public-unimplemented number) (def/public-unimplemented enable-top) + (define/public (delete which pos) - (void)) ;; FIXME + (atomically + (set! menus (append (take menus pos) + (drop menus (add1 pos)))) + (RemoveMenu hmenu pos MF_BYPOSITION) + (refresh))) + + (define/private (refresh) + (when parent + (send parent draw-menu-bar))) (public [append-item append]) (define (append-item m lbl) (let ([l (append menus (list m))]) (atomically (set! menus l) - (send m set-parent this lbl hmenu)))) + (send m set-parent this lbl hmenu))) + (refresh)) (define/public (set-parent f) (SetMenu (send f get-hwnd) hmenu) - (DrawMenuBar (send f get-hwnd))))) + (set! parent f) + (send parent draw-menu-bar)))) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index daa901de..379d2db1 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -17,12 +17,6 @@ (let ([wb (hash-ref ids id #f)]) (and wb (weak-box-value wb)))) -(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT)) -(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD)) -(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16 - -> (r : _BOOL) - -> (unless r (failed 'ModifyMenuW)))) - (defclass menu-item% object% (define id diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 5ed3cec0..33f22ecf 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -48,6 +48,12 @@ (proc (car items) pos)] [else (loop (cdr items) (add1 pos))]))) + (define/public (set-menu-label bar-hmenu pos str) + (ModifyMenuW bar-hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP) + (cast hmenu _HMENU _UINT_PTR) + str)) + (define/public (set-label id str) (with-item id @@ -78,9 +84,14 @@ (lambda (i pos) (send i get-check hmenu pos)))) - (def/public-unimplemented delete-by-position) + (define/public (delete-by-position pos) + (RemoveMenu hmenu pos MF_BYPOSITION)) + (define/public (delete id) - (void)) + (with-item + id + (lambda (i pos) + (RemoveMenu hmenu pos MF_BYPOSITION)))) (public [append-item append]) (define (append-item id label help-str-or-submenu chckable?) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 320e530f..7ae2fedf 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -143,8 +143,7 @@ (define/override (control-scrolled) (when value-hwnd - (let ([val (get-value)]) - (SetWindowTextW value-hwnd (format "~s" val)))) + (set-text (get-value))) (queue-window-event this (lambda () (callback this (new control-event% @@ -152,7 +151,12 @@ [time-stamp (current-milliseconds)]))))) (define/public (set-value val) - (SendMessageW slider-hwnd TBM_SETPOS 1 val)) + (SendMessageW slider-hwnd TBM_SETPOS 1 val) + (when value-hwnd + (set-text val))) + + (define/private (set-text val) + (SetWindowTextW value-hwnd (format "~s" val))) (define/public (get-value) (SendMessageW slider-hwnd TBM_GETPOS 0 0))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 26856830..f280b81f 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -113,5 +113,6 @@ (bitwise-and v #xFFFF)) (define (MAKELONG a b) - (bitwise-ior (arithmetic-shift b 16) a)) + (bitwise-ior (arithmetic-shift b 16) + (bitwise-and a #xFFFF))) (define (MAKELPARAM a b) (MAKELONG a b)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 2c10cf68..95ed4e06 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -23,7 +23,11 @@ SetCursor GetDC ReleaseDC - InvalidateRect) + InvalidateRect + GetMenuState + CheckMenuItem + ModifyMenuW + RemoveMenu) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -72,3 +76,11 @@ (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) -> (unless r (failed 'InvalidateRect)))) + +(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT)) +(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD)) +(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16 + -> (r : _BOOL) + -> (unless r (failed 'ModifyMenuW)))) +(define-user32 RemoveMenu (_wfun _HMENU _UINT _UINT -> (r : _BOOL) + -> (unless r (failed 'RemoveMenu)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 2c381f8d..ba8c6590 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -181,12 +181,12 @@ (atomically (direct-show on?))) (define shown? #f) - (define/public (direct-show on?) + (define/public (direct-show on? [on-mode SW_SHOW]) ;; atomic mode (set! shown? (and on? #t)) (register-child-in-parent on?) (unless on? (not-focus-child this)) - (ShowWindow hwnd (if on? SW_SHOW SW_HIDE))) + (ShowWindow hwnd (if on? on-mode SW_HIDE))) (unless (memq 'invisible style) (show #t)) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index cff8412a..e8bd6f9a 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -6,7 +6,7 @@ (define my-txt #f) (define my-lb #f) -(define noisy? #t) +(define noisy? #f) (define mdi-frame #f) (define (mdi) From 13098d303ac479ca9bf7903e5d885786e4d53f6f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 1 Oct 2010 20:26:30 -0600 Subject: [PATCH 250/462] switch cocoa dialog% to common mixin original commit: ba581819fbc5bd3b0ca581d66295ac0b42a59da5 --- collects/mred/private/wx/cocoa/dialog.rkt | 31 +---- collects/mred/private/wx/cocoa/frame.rkt | 140 ++++++++++----------- collects/mred/private/wx/common/dialog.rkt | 7 +- 3 files changed, 73 insertions(+), 105 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index a07fc383..85b8e361 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -2,34 +2,15 @@ (require scheme/class "../../syntax.rkt" "../common/queue.rkt" + "../common/dialog.rkt" "../../lock.rkt" "frame.rkt") (provide dialog%) -(defclass dialog% frame% - (super-new [is-dialog? #t]) +(define dialog% + (class (dialog-mixin frame%) + (super-new [is-dialog? #t]) - (define close-sema #f) - - (define/override (direct-show on?) - (unless on? - (atomically - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f)))) - (super direct-show on?)) - - ;; #t result avoids children sheets - (define/override (get-sheet) #t) - - (define/override (show on?) - (if on? - (let ([s (atomically - (let ([s (or close-sema (make-semaphore))]) - (unless close-sema (set! close-sema s)) - (semaphore-peek-evt s)))]) - (super show on?) - (yield s) - (void)) - (super show on?)))) + ;; #t result avoids children sheets + (define/override (get-sheet) #t))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 76d206bb..cd3fbcbb 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -34,8 +34,6 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) -(define dialog-level-counter 0) - (define all-windows (make-hash)) (define-objc-mixin (MyWindowMethods Superclass) @@ -52,7 +50,8 @@ (queue-window*-event wxb (lambda (wx) (unless (other-modal? wx) (when (send wx on-close) - (send wx direct-show #f))))) + (atomically + (send wx direct-show #f)))))) #f] [-a _void (windowDidResize: [_id notification]) (when wxb @@ -187,21 +186,10 @@ (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) (define is-a-dialog? is-dialog?) - (define dialog-level 0) (define/public (frame-is-dialog?) is-a-dialog?) - (define/public (frame-relative-dialog-status win) - ;; called in event-pump thread - (cond - [is-a-dialog? (let ([dl (send win get-dialog-level)]) - (cond - [(= dl dialog-level) 'same] - [(dl . > . dialog-level) #f] - [else 'other]))] - [else #f])) - - (define/override (get-dialog-level) - ;; called in event-pump thread - dialog-level) + + (define/public (frame-relative-dialog-status win) #f) + (define/override (get-dialog-level) 0) (define/public (clean-up) ;; When a window is resized, then any drawing that is in flight @@ -215,65 +203,63 @@ (define/public (get-sheet) child-sheet) (define/public (set-sheet s) (set! child-sheet s)) + (define caption? (not (memq 'no-caption style))) + (define/public (can-have-sheet?) caption?) + (define/public (direct-show on?) - (as-entry - (lambda () - (when (and (not on?) - (eq? front this)) - (set! front #f) - (send empty-mb install)) - (if on? - (show-children) - (hide-children)) - (if on? - (begin - (when is-a-dialog? - (set! dialog-level-counter (add1 dialog-level-counter)) - (set! dialog-level dialog-level-counter)) - (if (and is-a-dialog? - (let ([p (get-parent)]) - (and p - (not (send p get-sheet))))) + ;; in atomic mode + (when (and (not on?) + (eq? front this)) + (set! front #f) + (send empty-mb install)) + (if on? + (show-children) + (hide-children)) + (if on? + (if (and is-a-dialog? (let ([p (get-parent)]) - (send p set-sheet this) - (tell (tell NSApplication sharedApplication) - beginSheet: cocoa - modalForWindow: (send p get-cocoa) - modalDelegate: #f - didEndSelector: #:type _SEL #f - contextInfo: #f)) - (tellv cocoa makeKeyAndOrderFront: #f))) - (begin - (when is-a-dialog? - (set! dialog-level 0) - (let ([p (get-parent)]) - (when (and p - (eq? this (send p get-sheet))) - (send p set-sheet #f) - (tell (tell NSApplication sharedApplication) - endSheet: cocoa)))) - (tellv cocoa orderOut: #f) - (let ([next - (atomically - (with-autorelease - (let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)]) - (begin0 - (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) - (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) - (and (tell #:type _BOOL win isVisible) - win)))))))]) - (cond - [next (tellv next makeKeyWindow)] - [root-fake-frame (send root-fake-frame install-mb)] - [else (void)])))) - (register-frame-shown this on?) - (let ([num (tell #:type _NSInteger cocoa windowNumber)]) - (if on? - (hash-set! all-windows num this) - (hash-remove! all-windows num))) - (when on? - (let ([b (eventspace-wait-cursor-count (get-eventspace))]) - (set-wait-cursor-mode (not (zero? b)))))))) + (and p + (send p can-have-sheet?) + (not (send p get-sheet))))) + (let ([p (get-parent)]) + (send p set-sheet this) + (tell (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) + (tellv cocoa makeKeyAndOrderFront: #f)) + (begin + (when is-a-dialog? + (let ([p (get-parent)]) + (when (and p + (eq? this (send p get-sheet))) + (send p set-sheet #f) + (tell (tell NSApplication sharedApplication) + endSheet: cocoa)))) + (tellv cocoa orderOut: #f) + (let ([next + (atomically + (with-autorelease + (let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)]) + (begin0 + (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) + (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) + (and (tell #:type _BOOL win isVisible) + win)))))))]) + (cond + [next (tellv next makeKeyWindow)] + [root-fake-frame (send root-fake-frame install-mb)] + [else (void)])))) + (register-frame-shown this on?) + (let ([num (tell #:type _NSInteger cocoa windowNumber)]) + (if on? + (hash-set! all-windows num this) + (hash-remove! all-windows num))) + (when on? + (let ([b (eventspace-wait-cursor-count (get-eventspace))]) + (set-wait-cursor-mode (not (zero? b)))))) (define/override (show on?) (let ([es (get-eventspace)]) @@ -290,7 +276,8 @@ (do-paint-children) (semaphore-post s))) (sync/timeout 1 s)))))) - (direct-show on?)) + (atomically + (direct-show on?))) (define/private (do-paint-children) (when saved-child @@ -300,7 +287,8 @@ (define/public (destroy) (when child-sheet (send child-sheet destroy)) - (direct-show #f)) + (atomically + (direct-show #f))) (define/override (hide-children) (when saved-child diff --git a/collects/mred/private/wx/common/dialog.rkt b/collects/mred/private/wx/common/dialog.rkt index a1aa765f..1548fb06 100644 --- a/collects/mred/private/wx/common/dialog.rkt +++ b/collects/mred/private/wx/common/dialog.rkt @@ -31,10 +31,9 @@ (unless on? (set! dialog-level 0)) (unless on? - (atomically - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f)))) + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f))) (super direct-show on?)) (define/override (show on?) From 94e7cacafcba49b2ad9758ae9bcab38b87a6007c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Oct 2010 08:55:03 -0600 Subject: [PATCH 251/462] Windows: use PLT_WIN_GTK for gtk; fix manifest embedding original commit: 815278fe432335ab131db5086aeaf4c1ea706999 --- collects/mred/private/wx/platform.rkt | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 14d6f126..2e067897 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -3,10 +3,14 @@ (provide (all-defined-out)) (define-runtime-path platform-lib - (case (system-type) - [(#;windows) '(lib "mred/private/wx/win32/platform.rkt")] - [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] - [(windows unix) '(lib "mred/private/wx/gtk/platform.rkt")])) + (let ([gtk-lib + '(lib "mred/private/wx/gtk/platform.rkt")]) + (case (system-type) + [(windows) (if (getenv "PLT_WIN_GTK") + gtk-lib + '(lib "mred/private/wx/win32/platform.rkt"))] + [(maxcosx) '(lib "mred/private/wx/cocoa/platform.rkt")] + [(unix) gtk-lib]))) (define-values (button% canvas% From 6698d00cbb44f72577389868d24f97737c713f11 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Oct 2010 09:42:55 -0600 Subject: [PATCH 252/462] cocoa: control-border in canvas% original commit: 631f0a6e347974f44a6560ab98e133b28bb89901 --- collects/mred/private/wx/cocoa/canvas.rkt | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 8b7c86fc..bac0ac13 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -27,7 +27,8 @@ ;; ---------------------------------------- -(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow NSImageView) +(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow + NSImageView NSTextFieldCell) (import-protocol NSComboBoxDelegate) @@ -116,11 +117,22 @@ (define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) (define-cocoa NSRectFill (_fun _NSRect -> _void)) +(define bezel-cell + (tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString "")) +(tellv bezel-cell setBezeled: #:type _BOOL #t) + (define-objc-class FocusView NSView [on?] (-a _void (setFocusState: [_BOOL is-on?]) (set! on? is-on?)) (-a _void (drawRect: [_NSRect r]) + (let ([f (tell #:type _NSRect self frame)]) + (tellv bezel-cell + drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2) + (let ([s (NSRect-size r)]) + (make-NSSize (- (NSSize-width s) 4) + (- (NSSize-height s) 4)))) + inView: self)) (when on? (let ([ctx (tell NSGraphicsContext currentContext)]) (tellv ctx saveGraphicsState) From c9d4a32c603d53f90e0088dcebdf93c06535739b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Oct 2010 20:07:47 -0600 Subject: [PATCH 253/462] win32: combo and cursor fixes original commit: 736607c28051a070c656b19d6a30b9385bbef73c --- collects/mred/private/wx/win32/canvas.rkt | 177 +++++++++++++++---- collects/mred/private/wx/win32/choice.rkt | 8 - collects/mred/private/wx/win32/const.rkt | 7 + collects/mred/private/wx/win32/frame.rkt | 5 +- collects/mred/private/wx/win32/item.rkt | 5 +- collects/mred/private/wx/win32/panel.rkt | 22 ++- collects/mred/private/wx/win32/tab-panel.rkt | 5 +- collects/mred/private/wx/win32/theme.rkt | 17 +- collects/mred/private/wx/win32/window.rkt | 30 ++-- collects/mred/private/wx/win32/wndclass.rkt | 2 +- collects/mred/private/wxme/editor-canvas.rkt | 40 +++-- 11 files changed, 230 insertions(+), 88 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 2a3f998e..a21d821d 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -14,15 +14,28 @@ "const.rkt" "wndclass.rkt" "window.rkt" - "dc.rkt") + "dc.rkt" + "item.rkt" + "theme.rkt") (provide canvas%) +(define WS_EX_STATICEDGE #x00020000) +(define WS_EX_CLIENTEDGE #x00000200) + (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) -> (unless r (failed 'ShowScrollbar)))) +(define _HRGN _pointer) +(define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) +(define DCX_WINDOW #x00000001) + +(define EP_EDITTEXT 1) +(define ETS_NORMAL 1) +(define ETS_DISABLE 4) + (define-cstruct _SCROLLINFO ([cbSize _UINT] [fMask _UINT] @@ -43,9 +56,11 @@ -> (r : _BOOL) -> (if r i (error 'GetScrollInfo "failed")))) +(define COMBO-WIDTH 18) + (define canvas% (canvas-mixin - (class window% + (class (item-mixin window%) (init parent x y w h style @@ -54,27 +69,72 @@ (inherit get-hwnd get-client-size - get-eventspace) + get-eventspace + set-control-font + subclass-control) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) + (define panel-hwnd + (and (memq 'combo style) + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f))) + + (define canvas-hwnd + (CreateWindowExW (cond + [(memq 'border style) WS_EX_STATICEDGE] + [(memq 'control-border style) WS_EX_CLIENTEDGE] + [else 0]) + "PLTCanvas" + #f + (bitwise-ior WS_CHILD + (if panel-hwnd WS_VISIBLE 0) + (if hscroll? WS_HSCROLL 0) + (if vscroll? WS_VSCROLL 0)) + 0 0 w h + (or panel-hwnd (send parent get-hwnd)) + #f + hInstance + #f)) + (define combo-hwnd + (and panel-hwnd + (CreateWindowExW 0 + "PLTCOMBOBOX" + "" + (bitwise-ior WS_CHILD WS_VISIBLE + CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 w h + panel-hwnd + #f + hInstance + #f))) + + (define hwnd (or panel-hwnd canvas-hwnd)) + (super-new [parent parent] - [hwnd - (CreateWindowExW 0 - "PLTCanvas" - #f - (bitwise-ior WS_CHILD WS_VISIBLE - (if hscroll? WS_HSCROLL 0) - (if vscroll? WS_VSCROLL 0)) - 0 0 w h - (send parent get-hwnd) - #f - hInstance - #f)] + [hwnd hwnd] + [extra-hwnds (if panel-hwnd + (list canvas-hwnd combo-hwnd) + null)] [style style]) - (define hwnd (get-hwnd)) + (when combo-hwnd + (set-control-font #f combo-hwnd) + (subclass-control combo-hwnd)) + + (define control-border-theme + (and (memq 'control-border style) + (OpenThemeData canvas-hwnd "Edit"))) (define/override (wndproc w msg wParam lParam default) (cond @@ -87,6 +147,23 @@ (do-backing-flush this dc hdc)) (EndPaint hdc ps)) 0] + [(= msg WM_NCPAINT) + (if control-border-theme + (let* ([r (GetWindowRect canvas-hwnd)] + [res (default w msg wParam lParam)] + [hdc (GetDCEx canvas-hwnd #f DCX_WINDOW)] + [wr (make-RECT 0 0 + (- (RECT-right r) (RECT-left r)) + (- (RECT-bottom r) (RECT-top r)))]) + (DrawThemeBackground control-border-theme + hdc + EP_EDITTEXT + ETS_NORMAL ;; or ETS_DISABLED? + wr + #f) + (ReleaseDC canvas-hwnd hdc) + 1) + (default w msg wParam lParam))] [(= msg WM_HSCROLL) (on-scroll-change SB_HORZ (LOWORD wParam)) 0] @@ -95,6 +172,9 @@ 0] [else (super wndproc w msg wParam lParam default)])) + (define/override (wndproc-for-ctlproc w msg wParam lParam default) + (default w msg wParam lParam)) + (define dc (new dc% [canvas this])) (send dc start-backing-retained) @@ -103,6 +183,19 @@ (define/override (on-resized) (send dc reset-backing-retained)) + (define/override (get-client-hwnd) + canvas-hwnd) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when panel-hwnd + (let* ([r (and (or (= w -1) (= h -1)) + (GetWindowRect hwnd))] + [w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)] + [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) + (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) + (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))) + ;; The `queue-paint' and `paint-children' methods ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) @@ -113,7 +206,7 @@ (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) - (define/public (get-flush-window) hwnd) + (define/public (get-flush-window) canvas-hwnd) (define/public (begin-refresh-sequence) (send dc suspend-flush)) @@ -124,7 +217,7 @@ (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) - (InvalidateRect hwnd #f #f)) + (InvalidateRect canvas-hwnd #f #f)) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) @@ -154,11 +247,11 @@ (when hscroll? (atomically (set! h-scroll-visible? (and h? #t)) - (ShowScrollBar hwnd SB_HORZ h?))) + (ShowScrollBar canvas-hwnd SB_HORZ h?))) (when vscroll? (atomically (set! v-scroll-visible? (and v? #t)) - (ShowScrollBar hwnd SB_VERT v?)))) + (ShowScrollBar canvas-hwnd SB_VERT v?)))) (define/public (set-scrollbars h-step v-step h-len v-len @@ -173,27 +266,27 @@ SIF_PAGE) 0 (+ len page -1) page pos 0)) (when hscroll? - (SetScrollInfo hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) + (SetScrollInfo canvas-hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) (when vscroll? - (SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) + (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) (def/public-unimplemented set-background-to-gray) (define/public (get-scroll-pos which) - (GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) + (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) (define/public (get-scroll-range which) - (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) 1))) (define/public (get-scroll-page which) - (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (SCROLLINFO-nPage i))) (define/public (set-scroll-pos which v) - (void (SetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) + (void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) (define/public (set-scroll-range which v) - (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE (if (if (eq? which 'vertical) v-scroll-visible? @@ -201,9 +294,9 @@ SIF_DISABLENOSCROLL 0))) (set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1)) - (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) (define/public (set-scroll-page which v) - (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE (if (if (eq? which 'vertical) v-scroll-visible? @@ -213,11 +306,11 @@ (set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) v)) (set-SCROLLINFO-nPage! i v) - (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) (define/public (on-scroll e) (void)) (define/private (on-scroll-change dir part) - (let ([i (GetScrollInfo hwnd dir)]) + (let ([i (GetScrollInfo canvas-hwnd dir)]) (let ([new-pos (cond [(= part SB_TOP) 0] @@ -231,7 +324,7 @@ (unless (= new-pos (SCROLLINFO-nPos i)) (set-SCROLLINFO-nPos! i new-pos) (set-SCROLLINFO-fMask! i SIF_POS) - (SetScrollInfo hwnd dir i #t) + (SetScrollInfo canvas-hwnd dir i #t) (queue-window-event this (lambda () @@ -244,12 +337,26 @@ (let loop () (pre-event-sync #t) (when (yield) (loop)))) (void)))))) - (define/override (definitely-wants-event? e) - #t) + (define/override (definitely-wants-event? w e) + (or (e . is-a? . key-event%) + (ptr-equal? w canvas-hwnd))) (define/public (on-combo-select i) (void)) (define/public (set-combo-text s) (void)) - (define/public (append-combo-item s) (void)) + (define/public (append-combo-item s) + (SendMessageW/str combo-hwnd CB_ADDSTRING 0 s)) + + (define/override (is-command? cmd) + (= cmd CBN_SELENDOK)) + + (define/public (do-command control-hwnd) + (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) + (queue-window-event this (lambda () (on-combo-select i))))) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? panel-hwnd a-hwnd) + (ptr-equal? canvas-hwnd a-hwnd) + (ptr-equal? combo-hwnd a-hwnd))) (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index c71cdcbb..2526a8d8 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -14,14 +14,6 @@ (provide choice%) -(define CBS_DROPDOWNLIST #x0003) -(define CB_INSERTSTRING #x014A) -(define CB_SETCURSEL #x014E) -(define CB_GETCURSEL #x0147) -(define CBN_SELENDOK 9) -(define CB_ADDSTRING #x0143) -(define CB_RESETCONTENT #x014B) - (define choice% (class item% (init parent cb label diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index cfc0bd73..b32a3072 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -612,3 +612,10 @@ (define HORZRES 8) (define VERTRES 10) +(define CBS_DROPDOWNLIST #x0003) +(define CB_INSERTSTRING #x014A) +(define CB_SETCURSEL #x014E) +(define CB_GETCURSEL #x0147) +(define CBN_SELENDOK 9) +(define CB_ADDSTRING #x0143) +(define CB_RESETCONTENT #x014B) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 87bf4e93..38fd5882 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -209,7 +209,7 @@ (SetFocus child-hwnd))) (define/private (set-frame-focus) - (when focus-window-path + (when (pair? focus-window-path) (SetFocus (send (last focus-window-path) get-focus-hwnd)))) (define/override (child-can-accept-focus?) @@ -280,7 +280,8 @@ (unless on? (error 'register-child-in-frame "did not expect #f")) (unless (or (not saved-child) (eq? child saved-child)) (error 'register-child-in-frame "expected only one child")) - (set! saved-child child)) + (set! saved-child child) + (send child set-arrow-cursor)) (define/override (register-child-in-parent on?) (void)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index c4f93ee7..6f8491ff 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -56,7 +56,10 @@ (queue-window-event this (lambda () (on-kill-focus))) (default w msg wParam lParam)] [else - (wndproc w msg wParam lParam default)]))) + (wndproc-for-ctlproc w msg wParam lParam default)]))) + + (define/public (wndproc-for-ctlproc w msg wParam lParam default) + (wndproc w msg wParam lParam default)) (define/public (default-ctlproc w msg wParam lParam) (let loop ([l old-control-procs]) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 1acd02b6..f1aae1b4 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -3,7 +3,8 @@ "../../syntax.rkt" "window.rkt" "wndclass.rkt" - "const.rkt") + "const.rkt" + "cursor.rkt") (provide panel-mixin panel%) @@ -35,10 +36,11 @@ (define mouse-in-child #f) (define/override (generate-mouse-ins in-window mk) - (unless (eq? in-window mouse-in-child) - (when mouse-in-child - (send mouse-in-child send-leaves mk)) - (set! mouse-in-child in-window)) + (unless (eq? in-window this) + (unless (eq? in-window mouse-in-child) + (when mouse-in-child + (send mouse-in-child send-leaves mk)) + (set! mouse-in-child in-window))) (super generate-mouse-ins in-window mk)) (define/override (reset-cursor default) @@ -89,4 +91,12 @@ #f hInstance #f)] - [style style]))) + [style style]) + + ;; For panel in a frame, adjust default cursor to arrow: + (define arrow-cursor? #f) + (define/public (set-arrow-cursor) (set! arrow-cursor? #t)) + (define/override (generate-parent-mouse-ins mk) + (or (super generate-parent-mouse-ins mk) + (and arrow-cursor? + (get-arrow-cursor)))))) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 16b709df..94378acf 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -44,7 +44,8 @@ (define callback void) (inherit auto-size set-control-font - is-shown-to-root?) + is-shown-to-root? + subclass-control) (define hwnd (CreateWindowExW 0 @@ -74,6 +75,8 @@ [hwnd hwnd] [style style]) + (subclass-control hwnd) + (define/override (get-client-hwnd) client-hwnd) diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt index 5a469d72..039f4683 100644 --- a/collects/mred/private/wx/win32/theme.rkt +++ b/collects/mred/private/wx/win32/theme.rkt @@ -1,5 +1,6 @@ #lang racket/base (require ffi/unsafe + ffi/unsafe/alloc "utils.ss" "const.ss" "types.ss") @@ -8,7 +9,11 @@ get-theme-font-face get-theme-font-size _LOGFONT-pointer + OpenThemeData + CloseThemeData DrawThemeParentBackground + DrawThemeBackground + DrawThemeEdge EnableThemeDialogTexture) (define _HTHEME (_cpointer 'HTHEME)) @@ -45,10 +50,12 @@ [lfPitchAndFamily _BYTE] [lfFaceName _FaceName])) ; 32 of them -(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)) (define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT) -> (when (negative? r) - (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))) + (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r)))) + #:wrap (deallocator)) +(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME) + #:wrap (allocator CloseThemeData)) (define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT)) -> (r : _HRESULT) -> (if (negative? r) @@ -61,9 +68,15 @@ (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r)) f))) +(define-uxtheme DrawThemeBackground (_wfun _HTHEME _HDC _int _int _RECT-pointer (_or-null _RECT-pointer) -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeBackground "failed: ~s" (bitwise-and #xFFFF r))))) (define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT) -> (when (negative? r) (error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r))))) +(define-uxtheme DrawThemeEdge (_wfun _HWND _HDC _int _int _RECT-pointer _int _int _RECT-pointer -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeEdge "failed: ~s" (bitwise-and #xFFFF r))))) (define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT) -> (when (negative? r) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index ba8c6590..f6582a4c 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -129,21 +129,21 @@ (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key wParam lParam #f #f))] + (do-key w wParam lParam #f #f))] [(= msg WM_KEYDOWN) - (do-key wParam lParam #f #f) + (do-key w wParam lParam #f #f) 0] [(= msg WM_KEYUP) - (do-key wParam lParam #f #t) + (do-key w wParam lParam #f #t) 0] [(and (= msg WM_SYSCHAR) (= wParam VK_MENU)) (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key wParam lParam #t #f))] + (do-key w wParam lParam #t #f))] [(= msg WM_CHAR) - (do-key wParam lParam #t #f) + (do-key w wParam lParam #t #f) 0] [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] @@ -391,10 +391,10 @@ (define/public (get-top-frame) (send parent get-top-frame)) - (define/private (do-key wParam lParam is-char? is-up?) + (define/private (do-key w wParam lParam is-char? is-up?) (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) (and e - (if (definitely-wants-event? e) + (if (definitely-wants-event? w e) (begin (queue-window-event this (lambda () (dispatch-on-char/sync e))) #t) @@ -495,10 +495,10 @@ c)))))) (when (memq type '(left-down right-down middle-down)) (set-focus)) - (handle-mouse-event (make-e type))))) + (handle-mouse-event control-hwnd (make-e type))))) - (define (handle-mouse-event e) - (if (definitely-wants-event? e) + (define/private (handle-mouse-event w e) + (if (definitely-wants-event? w e) (begin (queue-window-event this (lambda () (dispatch-on-event/sync e))) #t) @@ -513,8 +513,10 @@ (begin (set! mouse-in? #t) (let ([parent-cursor (generate-parent-mouse-ins mk)]) - (handle-mouse-event (mk 'enter)) - (or cursor-handle parent-cursor))))) + (handle-mouse-event #f (mk 'enter)) + (let ([c (or cursor-handle parent-cursor)]) + (set! effective-cursor-handle c) + c))))) (define/public (generate-parent-mouse-ins mk) (send parent generate-mouse-ins this mk)) @@ -523,14 +525,14 @@ (set! mouse-in? #f) (let ([e (mk 'leave)]) (if (eq? (current-eventspace) (get-eventspace)) - (handle-mouse-event e) + (handle-mouse-event #f e) (queue-window-event this (lambda () (dispatch-on-event/sync e)))))) (define/public (send-child-leaves mk) #f) - (define/public (definitely-wants-event? e) + (define/public (definitely-wants-event? w e) #f) (define/public (dispatch-on-char/sync e) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 30dae5f0..c25b03cf 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -100,7 +100,7 @@ #f ; menu "PLTFrame"))) -(void (RegisterClassW (make-WNDCLASS 0 ; not CS_OWNDC ! +(void (RegisterClassW (make-WNDCLASS CS_OWNDC wind-proc 0 0 diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index 521d9cfb..f6c079fe 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -391,24 +391,28 @@ (send event button-down?)) (set-focus) (on-focus #t)) - - (when (and media - (not (send media get-printing))) - (using-admin - (when media - (set-custom-cursor - (send media adjust-cursor event))) - (when media - (send media on-event event)))) - - (when (send event dragging?) - (let-boxes ([cw 0] - [ch 0]) - (get-client-size cw ch) - (when (or (x . < . 0) - (y . < . 0) - (x . > . cw) - (y . > . ch)) + + (let ([out-of-client? + (let-boxes ([cw 0] + [ch 0]) + (get-client-size cw ch) + (or (x . < . 0) + (y . < . 0) + (x . > . cw) + (y . > . ch)))]) + + (when (and media + (not (send media get-printing))) + (using-admin + (when media + (set-custom-cursor + (and (not out-of-client?) + (send media adjust-cursor event)))) + (when media + (send media on-event event)))) + + (when (send event dragging?) + (when out-of-client? ;; Dragging outside the canvas: auto-generate more events because the buffer ;; is probably scrolling. But make sure we're shown. (when (is-shown-to-root?) From 3156ae4ee80a19ad5ef7eb0cdc049454058bd3d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Oct 2010 20:29:07 -0600 Subject: [PATCH 254/462] win32: transparent canvases original commit: a6d25247283f5aef4287b78018f0cafb502f7559 --- collects/mred/private/wx/win32/canvas.rkt | 3 ++- collects/mred/private/wx/win32/wndclass.rkt | 6 ++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index a21d821d..95a79c79 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -31,6 +31,7 @@ (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) +(define DCX_CACHE #x00000002) (define EP_EDITTEXT 1) (define ETS_NORMAL 1) @@ -151,7 +152,7 @@ (if control-border-theme (let* ([r (GetWindowRect canvas-hwnd)] [res (default w msg wParam lParam)] - [hdc (GetDCEx canvas-hwnd #f DCX_WINDOW)] + [hdc (GetDCEx canvas-hwnd #f (bitwise-ior DCX_CACHE DCX_WINDOW))] [wr (make-RECT 0 0 (- (RECT-right r) (RECT-left r)) (- (RECT-bottom r) (RECT-top r)))]) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index c25b03cf..313f2076 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -100,16 +100,14 @@ #f ; menu "PLTFrame"))) -(void (RegisterClassW (make-WNDCLASS CS_OWNDC +(void (RegisterClassW (make-WNDCLASS 0 ; using CS_OWNDC creates trouble when resizing? wind-proc 0 0 hInstance #f #f - (let ([p (ptr-add #f (+ COLOR_WINDOW 1))]) - (cpointer-push-tag! p 'HBRUSH) - p) + #f ; transparent #f ; menu "PLTCanvas"))) From 28c1d75f318fabdd4498faaed3f29d1a382fabf1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Oct 2010 20:44:51 -0600 Subject: [PATCH 255/462] fix platform-dispatch typo original commit: 0f754f2878ff2694c817fb2c6e556dfcb34e8290 --- collects/mred/private/wx/platform.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 2e067897..a3b1555a 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -9,7 +9,7 @@ [(windows) (if (getenv "PLT_WIN_GTK") gtk-lib '(lib "mred/private/wx/win32/platform.rkt"))] - [(maxcosx) '(lib "mred/private/wx/cocoa/platform.rkt")] + [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] [(unix) gtk-lib]))) (define-values (button% From b7e73d0935ca1a4ece4959ac2a59e0cae709a141 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 08:23:58 -0600 Subject: [PATCH 256/462] move gtk+cocoa canvas autoscroll support to common mixin original commit: 682355def4fe957d1fedfbd22c8453fde1d489bd --- collects/mred/private/wx/cocoa/canvas.rkt | 121 +++++------------- .../mred/private/wx/common/canvas-mixin.rkt | 106 ++++++++++++++- collects/mred/private/wx/gtk/canvas.rkt | 89 +++---------- 3 files changed, 158 insertions(+), 158 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index bac0ac13..03fa4dac 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -178,7 +178,7 @@ (define canvas% (canvas-mixin - (class window% + (class (canvas-autoscroll-mixin window%) (init parent x y w h style @@ -195,17 +195,16 @@ register-as-child get-size get-position set-focus - client-to-screen) + client-to-screen + is-auto-scroll? get-virtual-width get-virtual-height + reset-auto-scroll + refresh-for-autoscroll) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) (define hscroll-ok? (and (memq 'hscroll style) #t)) (define hscroll? hscroll-ok?) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) - (define wants-focus? (not (memq 'no-focus style))) (define is-combo? (memq 'combo style)) (define has-control-border? (and (not is-combo?) @@ -309,8 +308,8 @@ (when (dc . is-a? . dc%) (send dc reset-backing-retained) (send dc set-auto-scroll - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0))) + (if (is-auto-scroll?) (scroll-pos h-scroller) 0) + (if (is-auto-scroll?) (scroll-pos v-scroller) 0))) (when refresh? (refresh))) (define/override (get-client-size xb yb) @@ -380,7 +379,7 @@ (is-shown-to-root?)) (atomically (resume-all-reg-blits))) (fix-dc) - (when auto-scroll? + (when (is-auto-scroll?) (reset-auto-scroll 0 0)) (on-size 0 0)) @@ -406,69 +405,25 @@ (get-size w h) (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) h-len)) - (set! virtual-height (and (positive? v-len) v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] - [else - (let ([a? auto-scroll?]) - (set! auto-scroll? #f) - (when a? (fix-dc))) ; disable scroll offsets - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) - (set! virtual-width #f) - (set! virtual-height #f)])) + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw - 0)] - [v-page (if virtual-height - ch - 0)]) - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) + (define/override (reset-dc-for-autoscroll) + (fix-dc)) - (define/private (refresh-for-autoscroll) - (fix-dc) - (refresh)) - - (define (update which scroll- v) + (define/private (update which scroll- v) (if (eq? which 'vertical) (scroll- v-scroller v) (scroll- h-scroller v))) @@ -629,7 +584,7 @@ 'thumb] [else #f])]) (when kind - (if auto-scroll? + (if (is-auto-scroll?) (refresh-for-autoscroll) (on-scroll (new scroll-event% [event-type kind] @@ -690,22 +645,15 @@ (define/public (scroll x y) (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) - (when auto-scroll? (refresh-for-autoscroll))) + (when (is-auto-scroll?) (refresh-for-autoscroll))) (def/public-unimplemented warp-pointer) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (scroll-pos h-scroller) - 0)) - (set-box! yb (if virtual-height - (scroll-pos v-scroller) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (define/override (get-virtual-h-pos) + (scroll-pos h-scroller)) + + (define/override (get-virtual-v-pos) + (scroll-pos v-scroller)) (define/public (set-resize-corner on?) (void)) @@ -721,11 +669,6 @@ (define/public (is-flipped?) (tell #:type _BOOL (get-cocoa-content) isFlipped)) - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) - (define blits null) (define reg-blits null) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 2316c727..97309496 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -2,11 +2,115 @@ (require racket/class "backing-dc.rkt") -(provide canvas-mixin) +(provide canvas-autoscroll-mixin + canvas-mixin) +;; Implements canvas autoscroll, applied *before* platform-specific canvas +;; methods: +(define (canvas-autoscroll-mixin %) + (class % + (super-new) + + (inherit get-client-size + refresh) + + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + + (define/public (is-auto-scroll?) auto-scroll?) + (define/public (get-virtual-height) virtual-height) + (define/public (get-virtual-width) virtual-width) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (set! virtual-width #f) + (set! virtual-height #f) + (when a? (reset-dc-for-autoscroll))) ; disable scroll offsets + (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos)])) + + ;; To be overridden: + (define/public (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (void)) + + (define/public (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (do-set-scrollbars 1 1 + h-len v-len + h-page v-page + h-pos v-pos))))) + + ;; To be overridden: + (define/public (reset-dc-for-autoscroll) + (void)) + + (define/public (refresh-for-autoscroll) + (reset-dc-for-autoscroll) + (refresh)) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (get-virtual-h-pos) + 0)) + (set-box! yb (if virtual-height + (get-virtual-v-pos) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + + ;; To be overridden: + (define/public (get-virtual-h-pos) 0) + (define/public (get-virtual-v-pos) 0) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) + +;; Implements canvas refresh, applied *after* platform-specific canvas +;; methods: (define (canvas-mixin %) (class % (super-new) + (inherit request-canvas-flush-delay cancel-canvas-flush-delay queue-canvas-refresh-event diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index ef389076..53c883a8 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -181,7 +181,7 @@ (define canvas% (canvas-mixin - (class (client-size-mixin window%) + (class (canvas-autoscroll-mixin (client-size-mixin window%)) (init parent x y w h style @@ -191,7 +191,10 @@ (inherit get-gtk set-size get-size get-client-size on-size get-top-win set-auto-size - adjust-client-delta infer-client-delta) + adjust-client-delta infer-client-delta + is-auto-scroll? get-virtual-width get-virtual-height + reset-auto-scroll + refresh-for-autoscroll) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -199,10 +202,6 @@ (define margin (if has-border? 1 0)) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) - (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box combo-button-gtk @@ -386,10 +385,10 @@ (send dc reset-backing-retained) (refresh) (send dc set-auto-scroll - (if virtual-width + (if (get-virtual-width) (gtk_adjustment_get_value hscroll-adj) 0) - (if virtual-height + (if (get-virtual-height) (gtk_adjustment_get_value vscroll-adj) 0))) @@ -438,48 +437,15 @@ (gtk_adjustment_configure adj 0 0 1 1 1 1) (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))) - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (let ([h-page (if (zero? h-len) 0 h-page)] - [v-page (if (zero? v-len) 0 v-page)]) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) - (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] - [else - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)) - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw - 0)] - [v-page (if virtual-height - ch - 0)]) - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) - - (define/private (refresh-for-autoscroll) - (reset-dc) - (refresh)) + (define/override (reset-dc-for-autoscroll) + (reset-dc)) (define/private (dispatch which proc [default (void)]) (if (eq? which 'vertical) @@ -559,7 +525,7 @@ (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) - (if auto-scroll? + (if (is-auto-scroll?) (refresh-for-autoscroll) (on-scroll (new scroll-event% [event-type 'thumb] @@ -572,29 +538,16 @@ (lambda () (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)))) - (when auto-scroll? (refresh-for-autoscroll))) + (when (is-auto-scroll?) (refresh-for-autoscroll))) (def/public-unimplemented warp-pointer) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0)) - (set-box! yb (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (define/override (get-virtual-h-pos) + (gtk_adjustment_get_value hscroll-adj)) + (define/override (get-virtual-v-pos) + (gtk_adjustment_get_value vscroll-adj)) (define/public (set-resize-corner on?) (void)) - - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) (define reg-blits null) From 2c639351de484274f75acf6297d8736b5c80faa8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 08:54:19 -0600 Subject: [PATCH 257/462] win32: canvas autoscroll original commit: b459fcf91cee9470fbe5de9332b09940d0c6b95b --- collects/mred/private/wx/gtk/canvas.rkt | 1 - collects/mred/private/wx/win32/canvas.rkt | 92 +++++++++++++++++------ collects/mred/private/wx/win32/window.rkt | 70 ++++++++--------- 3 files changed, 104 insertions(+), 59 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 53c883a8..6fadee01 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -193,7 +193,6 @@ set-auto-size adjust-client-delta infer-client-delta is-auto-scroll? get-virtual-width get-virtual-height - reset-auto-scroll refresh-for-autoscroll) (define is-combo? (memq 'combo style)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 95a79c79..5be59d27 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -37,6 +37,9 @@ (define ETS_NORMAL 1) (define ETS_DISABLE 4) +(define HTHSCROLL 6) +(define HTVSCROLL 7) + (define-cstruct _SCROLLINFO ([cbSize _UINT] [fMask _UINT] @@ -61,7 +64,7 @@ (define canvas% (canvas-mixin - (class (item-mixin window%) + (class (canvas-autoscroll-mixin (item-mixin window%)) (init parent x y w h style @@ -72,7 +75,10 @@ get-client-size get-eventspace set-control-font - subclass-control) + subclass-control + is-auto-scroll? get-virtual-width get-virtual-height + reset-auto-scroll + refresh-for-autoscroll) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) @@ -182,7 +188,17 @@ (define/public (get-dc) dc) (define/override (on-resized) - (send dc reset-backing-retained)) + (reset-dc)) + + (define/private (reset-dc) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if (get-virtual-width) + (get-virtual-h-pos) + 0) + (if (get-virtual-height) + (get-virtual-v-pos) + 0))) (define/override (get-client-hwnd) canvas-hwnd) @@ -232,9 +248,6 @@ (unless (zero? paint-suspended) (set! paint-suspended (sub1 paint-suspended))))) - (define/public (get-virtual-size w h) - (get-client-size w h)) - (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) (define/public (get-canvas-background) (if transparent? @@ -254,11 +267,10 @@ (set! v-scroll-visible? (and v? #t)) (ShowScrollBar canvas-hwnd SB_VERT v?)))) - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) (define (make-info len page pos vis?) (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) @@ -271,6 +283,15 @@ (when vscroll? (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) + (define/override (reset-dc-for-autoscroll) + (reset-dc) + (refresh)) + + (define/override (get-virtual-h-pos) + (GetScrollPos canvas-hwnd SB_HORZ)) + (define/override (get-virtual-v-pos) + (GetScrollPos canvas-hwnd SB_VERT)) + (def/public-unimplemented set-background-to-gray) (define/public (get-scroll-pos which) @@ -326,21 +347,41 @@ (set-SCROLLINFO-nPos! i new-pos) (set-SCROLLINFO-fMask! i SIF_POS) (SetScrollInfo canvas-hwnd dir i #t) - (queue-window-event - this - (lambda () - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] - [position new-pos])))) + (if (is-auto-scroll?) + (refresh-for-autoscroll) + (queue-window-event + this + (lambda () + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] + [position new-pos]))))) (constrained-reply (get-eventspace) (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) (void)))))) - (define/override (definitely-wants-event? w e) - (or (e . is-a? . key-event%) - (ptr-equal? w canvas-hwnd))) + (define/override (definitely-wants-event? w msg wParam e) + (cond + [(e . is-a? . key-event%) + ;; All key events to canvas, event for combo: + #t] + [(and (or (= wParam HTVSCROLL) + (= wParam HTHSCROLL)) + (or (= msg WM_NCLBUTTONDOWN) + (= msg WM_NCRBUTTONDOWN) + (= msg WM_NCMBUTTONDOWN) + (= msg WM_NCLBUTTONDBLCLK) + (= msg WM_NCRBUTTONDBLCLK) + (= msg WM_NCMBUTTONDBLCLK) + (= msg WM_NCLBUTTONUP) + (= msg WM_NCRBUTTONUP) + (= msg WM_NCMBUTTONUP))) + ;; let scrollbar handle event: + #f] + [else + ;; otherwise, just handle events to canvas: + (ptr-equal? w canvas-hwnd)])) (define/public (on-combo-select i) (void)) (define/public (set-combo-text s) (void)) @@ -359,9 +400,14 @@ (ptr-equal? canvas-hwnd a-hwnd) (ptr-equal? combo-hwnd a-hwnd))) - (def/public-unimplemented scroll) + (define/public (scroll x y) + (when (x . > . 0) + (set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal))))) + (when (y . > . 0) + (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) + (when (is-auto-scroll?) (refresh-for-autoscroll))) + (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) (define/public (set-resize-corner on?) (void))))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index f6582a4c..8d519681 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -129,21 +129,21 @@ (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w wParam lParam #f #f))] + (do-key w msg wParam lParam #f #f))] [(= msg WM_KEYDOWN) - (do-key w wParam lParam #f #f) + (do-key w msg wParam lParam #f #f) 0] [(= msg WM_KEYUP) - (do-key w wParam lParam #f #t) + (do-key w msg wParam lParam #f #t) 0] [(and (= msg WM_SYSCHAR) (= wParam VK_MENU)) (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w wParam lParam #t #f))] + (do-key w msg wParam lParam #t #f))] [(= msg WM_CHAR) - (do-key w wParam lParam #t #f) + (do-key w msg wParam lParam #t #f) 0] [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] @@ -391,10 +391,10 @@ (define/public (get-top-frame) (send parent get-top-frame)) - (define/private (do-key w wParam lParam is-char? is-up?) + (define/private (do-key w msg wParam lParam is-char? is-up?) (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) (and e - (if (definitely-wants-event? w e) + (if (definitely-wants-event? w msg wParam e) (begin (queue-window-event this (lambda () (dispatch-on-char/sync e))) #t) @@ -406,52 +406,52 @@ (define/public (try-mouse w msg wParam lParam) (cond [(= msg WM_NCRBUTTONDOWN) - (do-mouse w #t 'right-down wParam lParam)] + (do-mouse w msg #t 'right-down wParam lParam)] [(= msg WM_NCRBUTTONUP) - (do-mouse w #t 'right-up wParam lParam)] + (do-mouse w msg #t 'right-up wParam lParam)] [(= msg WM_NCRBUTTONDBLCLK) - (do-mouse w #t 'right-down wParam lParam)] + (do-mouse w msg #t 'right-down wParam lParam)] [(= msg WM_NCMBUTTONDOWN) - (do-mouse w #t 'middle-down wParam lParam)] + (do-mouse w msg #t 'middle-down wParam lParam)] [(= msg WM_NCMBUTTONUP) - (do-mouse w #t 'middle-up wParam lParam)] + (do-mouse w msg #t 'middle-up wParam lParam)] [(= msg WM_NCMBUTTONDBLCLK) - (do-mouse w #t 'middle-down wParam lParam)] + (do-mouse w msg #t 'middle-down wParam lParam)] [(= msg WM_NCLBUTTONDOWN) - (do-mouse w #t 'left-down wParam lParam)] + (do-mouse w msg #t 'left-down wParam lParam)] [(= msg WM_NCLBUTTONUP) - (do-mouse w #t 'left-up wParam lParam)] + (do-mouse w msg #t 'left-up wParam lParam)] [(= msg WM_NCLBUTTONDBLCLK) - (do-mouse w #t 'left-down wParam lParam)] + (do-mouse w msg #t 'left-down wParam lParam)] [(and (= msg WM_NCMOUSEMOVE) (not (= wParam HTVSCROLL)) (not (= wParam HTHSCROLL))) - (do-mouse w #t 'motion wParam lParam)] + (do-mouse w msg #t 'motion wParam lParam)] [(= msg WM_RBUTTONDOWN) - (do-mouse w #f 'right-down wParam lParam)] + (do-mouse w msg #f 'right-down wParam lParam)] [(= msg WM_RBUTTONUP) - (do-mouse w #f 'right-up wParam lParam)] + (do-mouse w msg #f 'right-up wParam lParam)] [(= msg WM_RBUTTONDBLCLK) - (do-mouse w #f 'right-down wParam lParam)] + (do-mouse w msg #f 'right-down wParam lParam)] [(= msg WM_MBUTTONDOWN) - (do-mouse w #f 'middle-down wParam lParam)] + (do-mouse w msg #f 'middle-down wParam lParam)] [(= msg WM_MBUTTONUP) - (do-mouse w #f 'middle-up wParam lParam)] + (do-mouse w msg #f 'middle-up wParam lParam)] [(= msg WM_MBUTTONDBLCLK) - (do-mouse w #f 'middle-down wParam lParam)] + (do-mouse w msg #f 'middle-down wParam lParam)] [(= msg WM_LBUTTONDOWN) - (do-mouse w #f 'left-down wParam lParam)] + (do-mouse w msg #f 'left-down wParam lParam)] [(= msg WM_LBUTTONUP) - (do-mouse w #f 'left-up wParam lParam)] + (do-mouse w msg #f 'left-up wParam lParam)] [(= msg WM_LBUTTONDBLCLK) - (do-mouse w #f 'left-down wParam lParam)] + (do-mouse w msg #f 'left-down wParam lParam)] [(= msg WM_MOUSEMOVE) - (do-mouse w #f 'motion wParam lParam)] + (do-mouse w msg #f 'motion wParam lParam)] [(= msg WM_MOUSELEAVE) - (do-mouse w #f 'leave wParam lParam)] + (do-mouse w msg #f 'leave wParam lParam)] [else #f])) - (define/private (do-mouse control-hwnd nc? type wParam lParam) + (define/private (do-mouse control-hwnd msg nc? type wParam lParam) (let ([x (LOWORD lParam)] [y (HIWORD lParam)] [flags (if nc? 0 wParam)] @@ -495,10 +495,10 @@ c)))))) (when (memq type '(left-down right-down middle-down)) (set-focus)) - (handle-mouse-event control-hwnd (make-e type))))) + (handle-mouse-event control-hwnd msg wParam (make-e type))))) - (define/private (handle-mouse-event w e) - (if (definitely-wants-event? w e) + (define/private (handle-mouse-event w msg wParam e) + (if (definitely-wants-event? w msg wParam e) (begin (queue-window-event this (lambda () (dispatch-on-event/sync e))) #t) @@ -513,7 +513,7 @@ (begin (set! mouse-in? #t) (let ([parent-cursor (generate-parent-mouse-ins mk)]) - (handle-mouse-event #f (mk 'enter)) + (handle-mouse-event (get-client-hwnd) 0 0 (mk 'enter)) (let ([c (or cursor-handle parent-cursor)]) (set! effective-cursor-handle c) c))))) @@ -525,14 +525,14 @@ (set! mouse-in? #f) (let ([e (mk 'leave)]) (if (eq? (current-eventspace) (get-eventspace)) - (handle-mouse-event #f e) + (handle-mouse-event (get-client-hwnd) 0 0 e) (queue-window-event this (lambda () (dispatch-on-event/sync e)))))) (define/public (send-child-leaves mk) #f) - (define/public (definitely-wants-event? w e) + (define/public (definitely-wants-event? w msg wParam e) #f) (define/public (dispatch-on-char/sync e) From 3b842c7acffe0c6356d5d0ab17c3c81b8f44b4ea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 09:29:49 -0600 Subject: [PATCH 258/462] win32: clearing of transparent canvases original commit: 54fc1e276673afe6806110fc7c30220c17cc8411 --- collects/mred/private/wx/win32/canvas.rkt | 27 ++++++++++++++++++--- collects/mred/private/wx/win32/cursor.rkt | 2 +- collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/utils.rkt | 6 ++++- collects/mred/private/wx/win32/window.rkt | 3 ++- collects/mred/private/wx/win32/wndclass.rkt | 13 +++++----- 6 files changed, 39 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 5be59d27..47eb5333 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -28,6 +28,13 @@ (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) -> (unless r (failed 'ShowScrollbar)))) +(define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) +(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) +(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) + -> (unless r (failed 'DeleteObject)))) +(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) + -> (when (zero? r) (failed 'FillRect)))) + (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -149,9 +156,15 @@ (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) (unless (positive? paint-suspended) - (unless (do-backing-flush this dc hdc) - (queue-paint)) - (do-backing-flush this dc hdc)) + (let* ([hbrush (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref))]) + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush)) + (unless (do-backing-flush this dc hdc) + (queue-paint)))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -250,10 +263,16 @@ (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) + (define bg-colorref #xFFFFFF) (define/public (get-canvas-background) (if transparent? #f bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (set-canvas-background col) + (atomically + (set! bg-col col) + (set! bg-colorref (make-COLORREF (send col red) + (send col green) + (send col blue))))) (define h-scroll-visible? hscroll?) (define v-scroll-visible? vscroll?) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index ab98a79f..3af7c172 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -107,7 +107,7 @@ 16 16 ai xi)))) + (define/public (ok?) (and handle #t)) (define/public (get-handle) handle) - (def/public-unimplemented ok?) (super-new)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 958cad7d..651be348 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -58,7 +58,7 @@ (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit . args) (void)) -(define-unimplemented unregister-collecting-blit) +(define (unregister-collecting-blit . args) (void)) (define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 95ed4e06..20617d4e 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -15,7 +15,7 @@ GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str - GetSysColor GetRValue GetGValue GetBValue + GetSysColor GetRValue GetGValue GetBValue make-COLORREF MoveWindow ShowWindow EnableWindow @@ -59,6 +59,10 @@ (define (GetRValue v) (bitwise-and v #xFF)) (define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) (define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) +(define (make-COLORREF r g b) (bitwise-ior + r + (arithmetic-shift g 8) + (arithmetic-shift b 16))) (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) -> (unless r (failed 'MoveWindow)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 8d519681..a53dfecd 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -22,7 +22,8 @@ queue-window-refresh-event CreateWindowExW - GetWindowRect) + GetWindowRect + GetClientRect) (define (unhide-cursor) (void)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 313f2076..cd40e1b5 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -9,6 +9,7 @@ (provide hInstance DefWindowProcW + background-hbrush hwnd->wx any-hwnd->wx set-hwnd-wx! @@ -87,6 +88,10 @@ (define hInstance (GetModuleHandleW #f)) +(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p)) + (void (RegisterClassW (make-WNDCLASS CS_OWNDC wind-proc 0 @@ -94,9 +99,7 @@ hInstance (LoadIconW #f IDI_APPLICATION) #f - (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) - (cpointer-push-tag! p 'HBRUSH) - p) + background-hbrush #f ; menu "PLTFrame"))) @@ -118,9 +121,7 @@ hInstance #f #f - (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) - (cpointer-push-tag! p 'HBRUSH) - p) + background-hbrush #f ; menu "PLTPanel"))) From 32bc02c1b96f5869e4c6a75cba6aa5eabad3167e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 10:59:04 -0600 Subject: [PATCH 259/462] win32: fix submenus and other menu operations original commit: 22e7cb437db55a7e08a70e70b6d5f56b4c683544 --- collects/mred/private/wx/win32/menu-item.rkt | 1 + collects/mred/private/wx/win32/menu.rkt | 33 +++++++++++++++----- 2 files changed, 26 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 379d2db1..6141375a 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -39,6 +39,7 @@ (set! parent p) (set! label lbl) (set! checkable? chkbl?) + (set! submenu subm) id) (define/public (set-label hmenu pos str) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 33f22ecf..a13516f4 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class ffi/unsafe + (only-in racket/list drop take) "../../lock.rkt" "../../syntax.rkt" "utils.rkt" @@ -26,6 +27,8 @@ (define hmenu (CreatePopupMenu)) + (define/public (get-hmenu) hmenu) + (define/public (set-parent p lbl parent-hmenu) (set! label lbl) (set! parent p) @@ -60,8 +63,10 @@ (lambda (i pos) (send i set-label hmenu pos str)))) - (def/public-unimplemented set-help-string) - (def/public-unimplemented number) + (define/public (set-help-string id str) + (void)) + + (define/public (number) (length items)) (define/public (enable id on?) (with-item @@ -84,25 +89,37 @@ (lambda (i pos) (send i get-check hmenu pos)))) + (define/private (remove-item! pos) + (set! items + (append (take items pos) + (drop items (add1 pos))))) + (define/public (delete-by-position pos) - (RemoveMenu hmenu pos MF_BYPOSITION)) + (atomically + (remove-item! pos) + (RemoveMenu hmenu pos MF_BYPOSITION))) (define/public (delete id) (with-item id (lambda (i pos) - (RemoveMenu hmenu pos MF_BYPOSITION)))) + (atomically + (remove-item! pos) + (RemoveMenu hmenu pos MF_BYPOSITION))))) (public [append-item append]) (define (append-item id label help-str-or-submenu chckable?) (let ([i (id-to-menu-item id)]) (when i - (let ([id (send i set-parent this label chckable? - (and (help-str-or-submenu . is-a? . menu%) - help-str-or-submenu))]) + (let* ([submenu (and (help-str-or-submenu . is-a? . menu%) + help-str-or-submenu)] + [id (send i set-parent this label chckable? + submenu)]) (atomically (set! items (append items (list i))) - (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))))) + (if submenu + (AppendMenuW hmenu (bitwise-ior MF_POPUP MF_STRING) (send submenu get-hmenu) label) + (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label))))))) (define/public (append-separator) (atomically From 399e1759180a349bc3007859933b3f49b9d8df65 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 15:57:41 -0600 Subject: [PATCH 260/462] win32: clipboard and popup menu original commit: 90a1c3f4e40c54d5db5145f5805c683b8446002f --- collects/mred/private/wx/win32/clipboard.rkt | 150 ++++++++++++++++++- collects/mred/private/wx/win32/frame.rkt | 2 + collects/mred/private/wx/win32/menu.rkt | 27 +++- collects/mred/private/wx/win32/panel.rkt | 1 + collects/mred/private/wx/win32/types.rkt | 4 + collects/mred/private/wx/win32/utils.rkt | 8 + collects/mred/private/wx/win32/window.rkt | 17 +-- collects/mred/private/wx/win32/wndclass.rkt | 4 +- 8 files changed, 198 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index 76a531e5..355cbc53 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -1,12 +1,156 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw/bstr + "../common/queue.rkt" + "../../lock.rkt" + "types.rkt" + "utils.rkt" + "const.rkt" + "../../syntax.rkt" + "wndclass.rkt") (provide clipboard-driver% has-x-selection?) (define (has-x-selection?) #f) +;; Dummy window to own the clipboard: +(define clipboard-owner-hwnd + (CreateWindowExW 0 "PLTFrame" "" + WS_POPUP + 0 0 10 10 + #f + #f + hInstance + #f)) + +(define CF_UNICODETEXT 13) + +(define-user32 GetClipboardOwner (_wfun -> _HWND)) +(define-user32 OpenClipboard (_wfun _HWND -> _BOOL)) +(define-user32 CloseClipboard (_wfun -> _BOOL)) +(define-user32 EmptyClipboard (_wfun -> (r : _BOOL) -> (unless r (failed 'EmptyClipboard)))) + +(define-user32 RegisterClipboardFormatW (_wfun _string/utf-16 -> (r : _UINT) + -> (if (zero? r) + (failed 'RegisterClipboardFormatW) + r))) + +(define-kernel32 GlobalFree (_wfun _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'GlobalFree))) + #:wrap (deallocator)) +(define-kernel32 GlobalAlloc (_wfun _UINT _SIZE_T -> (r : _HANDLE) + -> (or r (failed 'GlobalAlloc))) + #:wrap (allocator GlobalFree)) + +(define-kernel32 GlobalLock (_wfun _HANDLE -> (r : _pointer) + -> (or r (failed 'GlobalLock)))) +(define-kernel32 GlobalUnlock (_wfun _HANDLE -> _BOOL)) +(define-kernel32 GlobalSize (_wfun _HANDLE -> (r : _SIZE_T) + -> (if (zero? r) + (failed 'GlobalSize) + r))) + +(define-user32 SetClipboardData (_wfun _UINT _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'SetClipboardData))) + ;; SetClipboardData accepts responsibility for the handle: + #:wrap (deallocator cadr)) + +(define-user32 GetClipboardData (_wfun _UINT -> _HANDLE)) + +(define GHND #x0042) + (defclass clipboard-driver% object% (init x-selection?) ; always #f + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (if (ptr-equal? clipboard-owner-hwnd + (GetClipboardOwner)) + client + (let ([c client]) + (set! client #f) + (drop-client c) + #f)))) + + (define/private (drop-client c) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))) + + (define/public (set-client c types) + (let* ([type-ids (for/list ([t (in-list types)]) + (if (string=? t "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW t)))] + [all-data (for/list ([t (in-list types)] + [t-id (in-list type-ids)]) + (let ([d (send c get-data t)]) + (cond + [(equal? t-id CF_UNICODETEXT) + ;; convert UTF-8 to UTF-16: + (let ([p (cast (bytes->string/utf-8 d #\?) + _string/utf-16 + _gcpointer)]) + (let ([len (let loop ([i 0]) + (if (and (zero? (ptr-ref p _byte i)) + (zero? (ptr-ref p _byte (add1 i)))) + (+ i 2) + (loop (+ i 2))))]) + (scheme_make_sized_byte_string p + len + 0)))] + [else + ;; no conversion: + d])))] + [all-handles (for/list ([d (in-list all-data)]) + (let ([h (GlobalAlloc GHND (bytes-length d))]) + (let ([p (GlobalLock h)]) + (memcpy p d (bytes-length d))) + (GlobalUnlock h) + h))]) + (if (null? types) + (drop-client c) + (atomically + (if (OpenClipboard clipboard-owner-hwnd) + (begin + (EmptyClipboard) + (for ([t (in-list type-ids)] + [h (in-list all-handles)]) + (SetClipboardData t h)) + (if (CloseClipboard) + (set! client c) + (drop-client c))) + (drop-client c)))))) + + (define/public (get-data format [as-text? #f]) + (let ([t (if (string=? format "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW format))]) + (atomically + (and (OpenClipboard clipboard-owner-hwnd) + (let ([d (GetClipboardData t)]) + (begin0 + (and d + (let ([hsize (GlobalSize d)] + [p (GlobalLock d)]) + (begin0 + (if as-text? + (cast p _pointer _string/utf-16) + (scheme_make_sized_byte_string p hsize 1)) + (GlobalUnlock d)))) + (CloseClipboard))))))) + + (define/public (get-text-data) + (or (get-data "TEXT" #t) "")) + (super-new)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 38fd5882..030cd0dc 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -212,6 +212,8 @@ (when (pair? focus-window-path) (SetFocus (send (last focus-window-path) get-focus-hwnd)))) + (define/override (can-accept-focus?) + #f) (define/override (child-can-accept-focus?) #t) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index a13516f4..db2f8d7a 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -4,6 +4,7 @@ (only-in racket/list drop take) "../../lock.rkt" "../../syntax.rkt" + "../common/event.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -16,15 +17,25 @@ -> (unless r (failed 'AppendMenuW)))) (define-user32 EnableMenuItem (_wfun _HMENU _UINT _UINT -> _BOOL)) +(define-user32 TrackPopupMenu(_wfun _HMENU _UINT _int _int _int _HWND (_or-null _RECT-pointer) + -> _int)) + +(define TPM_LEFTBUTTON #x0000) +(define TPM_RIGHTBUTTON #x0002) +(define TPM_NONOTIFY #x0080) +(define TPM_RETURNCMD #x0100) + (defclass menu% object% (init lbl - callback + cb font) (define label lbl) (define parent #f) (define items null) + (define callback cb) + (define hmenu (CreatePopupMenu)) (define/public (get-hmenu) hmenu) @@ -42,6 +53,20 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) + (define/public (popup gx gy hwnd call-callback) + (let ([cmd (TrackPopupMenu hmenu + (bitwise-ior + TPM_LEFTBUTTON + TPM_RIGHTBUTTON + TPM_NONOTIFY + TPM_RETURNCMD) + gx gy + 0 hwnd #f)]) + (let* ([e (new popup-event% [event-type 'menu-popdown])]) + (unless (zero? cmd) + (send e set-menu-id cmd)) + (call-callback (lambda () (callback this e)))))) + (define/private (with-item id proc) (let loop ([items items] [pos 0]) (cond diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index f1aae1b4..295e4584 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -3,6 +3,7 @@ "../../syntax.rkt" "window.rkt" "wndclass.rkt" + "utils.rkt" "const.rkt" "cursor.rkt") diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index f280b81f..4c3ccfd4 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -17,6 +17,7 @@ _SHORT _HRESULT _WCHAR + _SIZE_T _HINSTANCE _HWND @@ -27,6 +28,7 @@ _HDC _HFONT _HBITMAP + _HANDLE _COLORREF @@ -58,6 +60,7 @@ (define _BYTE _uint8) (define _HRESULT _int32) (define _WCHAR _int16) +(define _SIZE_T _long) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -68,6 +71,7 @@ (define _HDC (_cpointer/null 'HDC)) (define _HFONT (_cpointer/null 'HFONT)) (define _HBITMAP (_cpointer/null 'HBITMAP)) +(define _HANDLE (_cpointer/null 'HANDLE)) (define _COLORREF _DWORD) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 20617d4e..70786d9d 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,6 +12,7 @@ define-mz failed + CreateWindowExW GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -47,6 +48,13 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 CreateWindowExW (_wfun _DWORD + _string/utf-16 + _string/utf-16 + _UDWORD + _int _int _int _int + _HWND _HMENU _HINSTANCE _pointer + -> _HWND)) (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index a53dfecd..29fe8829 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -21,7 +21,6 @@ queue-window-event queue-window-refresh-event - CreateWindowExW GetWindowRect GetClientRect) @@ -41,13 +40,6 @@ (define HTHSCROLL 6) (define HTVSCROLL 7) -(define-user32 CreateWindowExW (_wfun _DWORD - _string/utf-16 - _string/utf-16 - _UDWORD - _int _int _int _int - _HWND _HMENU _HINSTANCE _pointer - -> _HWND)) (define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> (if r rect (failed 'GetWindowRect)))) (define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> @@ -305,7 +297,14 @@ (resize (max (->int (+ w dw)) (->int (* dlu-x min-w))) (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) - (def/public-unimplemented popup-menu) + (define/public (popup-menu m x y) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) + hwnd + (lambda (thunk) (queue-window-event this thunk))))) + (def/public-unimplemented center) (define/public (get-parent) parent) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index cd40e1b5..a0b94cce 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -71,7 +71,7 @@ (define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM)) (define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE)) (define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR)) -(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON)) +(define-user32 LoadIconW (_wfun _HINSTANCE _string/utf-16 -> _HICON)) (define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL) -> (if r i (failed 'GetClassInfoW)))) @@ -97,7 +97,7 @@ 0 0 hInstance - (LoadIconW #f IDI_APPLICATION) + (LoadIconW hInstance "WXSTD_FRAME") #f background-hbrush #f ; menu From 5ad1f535b4f3d90a231309d86a3b4b647f83cdd4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 18:21:49 -0600 Subject: [PATCH 261/462] win32: misc repairs original commit: b9b627f29406f39462edef2cc526bf553a73a75b --- collects/mred/private/mrtop.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 3 +++ collects/mred/private/wx/win32/frame.rkt | 7 +++++++ collects/mred/private/wx/win32/message.rkt | 22 +++++++++++++++++--- collects/mred/private/wx/win32/panel.rkt | 11 +++++++--- collects/mred/private/wx/win32/tab-panel.rkt | 5 ++++- collects/mred/private/wx/win32/utils.rkt | 4 ++++ collects/mred/private/wx/win32/window.rkt | 14 ++++++++++++- 8 files changed, 59 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index ca693a9b..f7a2dc97 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -98,7 +98,7 @@ (lambda (w h) (check-range-integer '(method top-level-window<%> resize) w) (check-range-integer '(method top-level-window<%> resize) h) - (send wx set-size -1 -1 w h)))] + (send wx set-size -11111 -11111 w h)))] [get-focus-window (entry-point (lambda () (let ([w (send wx get-focus-window)]) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 47eb5333..8f2c5351 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -380,6 +380,9 @@ (let loop () (pre-event-sync #t) (when (yield) (loop)))) (void)))))) + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? canvas-hwnd control-hwnd)) + (define/override (definitely-wants-event? w msg wParam e) (cond [(e . is-a? . key-event%) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 030cd0dc..fc336ffd 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -234,6 +234,13 @@ (set! mouse-frame this)) #f) + (define/override (send-child-leaves mk) + (if (eq? mouse-frame this) + (if saved-child + (send saved-child send-leaves mk) + #f) + #f)) + (define/override (reset-cursor default) (if wait-cursor-on? (void (SetCursor (get-wait-cursor))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index a72d0027..a0af26ea 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -31,13 +31,29 @@ (define IMAGE_ICON 1) (define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON)) +(define-kernel32 GetModuleFileNameW (_wfun _pointer _pointer _DWORD -> _DWORD)) + +(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON) + -> (or r (failed 'ExtractIconW)))) + +(define ERROR_INSUFFICIENT_BUFFER 122) (define app-icon (delay (let () - ;; GetModuleFileNameW(NULL, name, 1023); - ;; icn = ExtractIconW(NULL, name, 0); - (LoadIconW #f IDI_APPLICATION)))) + (let ([path + (let loop ([size 1024]) + (let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))]) + (let ([r (GetModuleFileNameW #f p size)]) + (cond + [(and (or (zero? r) (= r size)) + (= (GetLastError) ERROR_INSUFFICIENT_BUFFER)) + (loop (* size 2))] + [(zero? r) (failed 'GetModuleFileNameW)] + [else (cast p _gcpointer _string/utf-16)]))))]) + (if path + (ExtractIconW hInstance path 0) + (LoadIconW #f IDI_APPLICATION)))))) (define warning-icon (delay (LoadIconW #f IDI_WARNING))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 295e4584..1a3ffbd5 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -1,5 +1,6 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "window.rkt" "wndclass.rkt" @@ -13,7 +14,8 @@ (define (panel-mixin %) (class % (inherit is-enabled-to-root? - reset-cursor-in-child) + reset-cursor-in-child + get-client-hwnd) (super-new) @@ -64,6 +66,9 @@ #t) #f)) + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? (get-client-hwnd) control-hwnd)) + (define lbl-pos 'horizontal) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 94378acf..23e36a79 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -97,7 +97,10 @@ (define tab-height 0) (set-control-font #f) - (auto-size choices 0 0 0 0 #:combine-width + + (auto-size (if (null? choices) + '("Choice") + choices) + 0 0 0 0 #:combine-width + (lambda (w h) (set! tab-height (+ h 6)) (set-size -11111 -11111 diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 70786d9d..8847b4b5 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -8,10 +8,12 @@ define-user32 define-kernel32 define-comctl32 + define-shell32 define-uxtheme define-mz failed + GetLastError CreateWindowExW GetWindowLongW SetWindowLongW @@ -34,12 +36,14 @@ (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define shell32-lib (ffi-lib "shell32.dll")) (define uxtheme-lib (ffi-lib "uxtheme.dll")) (define-ffi-definer define-gdi32 gdi32-lib) (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-shell32 shell32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) (define-kernel32 GetLastError (_wfun -> _DWORD)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 29fe8829..06d37e61 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -54,6 +54,9 @@ (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-user32 SetCapture (_wfun _HWND -> _HWND)) +(define-user32 ReleaseCapture (_wfun -> _BOOL)) + (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -248,7 +251,7 @@ (let ([r (GetWindowRect hwnd)]) (MoveWindow hwnd (if (= x -11111) (RECT-left r) x) - (if (= y -11111) (RECT-right r) y) + (if (= y -11111) (RECT-top r) y) (if (= w -1) (- (RECT-right r) (RECT-left r)) w) (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) #t)) @@ -480,6 +483,12 @@ [alt-down #f] [time-stamp 0] [caps-down #f]))]) + (unless nc? + (when (wants-mouse-capture? control-hwnd) + (when (memq type '(left-down right-down middle-down)) + (SetCapture control-hwnd)) + (when (memq type '(left-up right-up middle-up)) + (ReleaseCapture)))) (if mouse-in? (if (send-child-leaves (lambda (type) (make-e type))) (cursor-updated-here) @@ -532,6 +541,9 @@ (define/public (send-child-leaves mk) #f) + (define/public (wants-mouse-capture? control-hwnd) + #f) + (define/public (definitely-wants-event? w msg wParam e) #f) From 5c3ee6847e7ed2009613ff0c52bbf28cdab4a17c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 18:38:06 -0600 Subject: [PATCH 262/462] move collecting-blit helper to common code original commit: 5dd568050b8ea693302f71561406d7be5e3bdfec --- collects/mred/private/wx/cocoa/canvas.rkt | 11 +-------- .../mred/private/wx/common/canvas-mixin.rkt | 17 +++++++++++++- collects/mred/private/wx/gtk/canvas.rkt | 23 +++++-------------- 3 files changed, 23 insertions(+), 28 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 03fa4dac..b691eb25 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -717,16 +717,7 @@ (cons win r))))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([on (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm)))]) + (let ([on (fix-bitmap-size on w h on-x on-y)]) (let ([img (bitmap->image on)]) (atomically (set! blits (cons (list x y w h img) blits)) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 97309496..cd1a3280 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -1,9 +1,11 @@ #lang racket/base (require racket/class + racket/draw "backing-dc.rkt") (provide canvas-autoscroll-mixin - canvas-mixin) + canvas-mixin + fix-bitmap-size) ;; Implements canvas autoscroll, applied *before* platform-specific canvas ;; methods: @@ -160,3 +162,16 @@ (when (or paint-queued (not (send (get-dc) can-backing-flush?))) (do-on-paint #f #f))))) + +;; useful for fixing the size of a collecting blit: +(define (fix-bitmap-size on w h on-x on-y) + (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 6fadee01..8393b6de 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -560,23 +560,12 @@ (cons win r)))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([fix-size (lambda (on on-x on-y) - (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm))))]) - (let ([on (fix-size on on-x on-y)] - [off (fix-size off off-x off-y)]) - (let ([on-pixbuf (bitmap->pixbuf on)] - [off-pixbuf (bitmap->pixbuf off)]) - (atomically - (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [off (fix-bitmap-size off w h off-x off-y)]) + (let ([on-pixbuf (bitmap->pixbuf on)] + [off-pixbuf (bitmap->pixbuf off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))) (define/public (unregister-collecting-blits) (atomically From a79eaeb04e631549b1cbaa2e4219b827891a633f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 20:06:06 -0600 Subject: [PATCH 263/462] win32: collecting-blit original commit: 5b7c8dd433dd44a00eac590262bdc7dcca635dbd --- collects/mred/private/wx/win32/canvas.rkt | 34 ++++++++++- collects/mred/private/wx/win32/gcwin.rkt | 68 +++++++++++++++++++++ collects/mred/private/wx/win32/hbitmap.rkt | 1 - collects/mred/private/wx/win32/procs.rkt | 6 +- collects/mred/private/wx/win32/utils.rkt | 5 +- collects/mred/private/wx/win32/wndclass.rkt | 11 ++++ 6 files changed, 119 insertions(+), 6 deletions(-) create mode 100644 collects/mred/private/wx/win32/gcwin.rkt diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 8f2c5351..cd561b59 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -16,6 +16,8 @@ "window.rkt" "dc.rkt" "item.rkt" + "hbitmap.rkt" + "gcwin.rkt" "theme.rkt") (provide canvas%) @@ -29,12 +31,14 @@ -> (unless r (failed 'ShowScrollbar)))) (define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) -(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) (define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) -> (unless r (failed 'DeleteObject)))) (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow)))) + (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -432,5 +436,31 @@ (def/public-unimplemented warp-pointer) (define/public (set-resize-corner on?) - (void))))) + (void)) + + (define reg-blits null) + + (define/private (register-one-blit x y w h on-hbitmap off-hbitmap) + (atomically + (let ([hwnd (create-gc-window canvas-hwnd x y w h)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc hwnd on-hbitmap w h) + (make-gc-hide-desc hwnd off-hbitmap w h))]) + (cons hwnd r))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [off (fix-bitmap-size off w h off-x off-y)]) + (let ([on-hbitmap (bitmap->hbitmap on)] + [off-hbitmap (bitmap->hbitmap off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-hbitmap off-hbitmap) reg-blits)))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (DestroyWindow (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) + diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt new file mode 100644 index 00000000..324170cb --- /dev/null +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -0,0 +1,68 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt") + +(provide scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-window + make-gc-show-desc + make-gc-hide-desc) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define-user32 ShowWindow/raw _fpointer + #:c-id ShowWindow) +(define-gdi32 BitBlt/raw _fpointer + #; + (_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL) + #:c-id BitBlt) +(define-gdi32 SelectObject/raw _fpointer + #:c-id SelectObject) + +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) + +(define SRCCOPY #x00CC0020) + +(define blit-hdc (CreateCompatibleDC #f)) + +(define (create-gc-window parent-hwnd x y w h) + (CreateWindowExW 0 + "PLTBlitTarget" + "" + (bitwise-ior WS_CHILD) + x y w h + parent-hwnd + #f + hInstance + #f)) + +(define (make-draw hwnd hbitmap w h) + (let ([hdc (GetDC hwnd)]) + null + (list + (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) + (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void + BitBlt/raw hdc 0 0 w h blit-hdc 0 0 SRCCOPY) + (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f)))) + +(define (make-gc-show-desc hwnd hbitmap w h) + (list->vector + (append + (list + (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_SHOW)) + (make-draw hwnd hbitmap w h)))) + +(define (make-gc-hide-desc hwnd hbitmap w h) + (list->vector + (append + ;; draw the ``off'' bitmap so it changes immediately: + (make-draw hwnd hbitmap w h) + ;; hide the window; it may take a while for the underlying canvas + ;; to refresh: + (list + (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_HIDE))))) + diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index 7458c8db..fe9aea80 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -14,7 +14,6 @@ (define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) -> (unless r (failed 'DeleteDC)))) -(define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP)) (define (bitmap->hbitmap bm) (let* ([w (send bm get-width)] diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 651be348..6e191c5f 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -57,8 +57,10 @@ (define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) -(define (register-collecting-blit . args) (void)) -(define (unregister-collecting-blit . args) (void)) +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 8847b4b5..273cca8a 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -30,7 +30,8 @@ GetMenuState CheckMenuItem ModifyMenuW - RemoveMenu) + RemoveMenu + SelectObject) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -100,3 +101,5 @@ -> (unless r (failed 'ModifyMenuW)))) (define-user32 RemoveMenu (_wfun _HMENU _UINT _UINT -> (r : _BOOL) -> (unless r (failed 'RemoveMenu)))) + +(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index a0b94cce..a3ea24fa 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -114,6 +114,17 @@ #f ; menu "PLTCanvas"))) +(void (RegisterClassW (make-WNDCLASS CS_OWNDC + DefWindowProcW + 0 + 0 + hInstance + #f + #f + #f + #f + "PLTBlitTarget"))) + (void (RegisterClassW (make-WNDCLASS 0 wind-proc 0 From 83ac8573e325aeaba39680ef582ec24932fdd399 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 09:30:48 -0600 Subject: [PATCH 264/462] win32: fix collecting blit original commit: b444555b6b0da63fb166bf82ac5ba38593b771de --- collects/mred/private/wx/win32/canvas.rkt | 10 ++--- collects/mred/private/wx/win32/gcwin.rkt | 50 ++++++--------------- collects/mred/private/wx/win32/wndclass.rkt | 25 ++++------- 3 files changed, 27 insertions(+), 58 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index cd561b59..f3b6c0c3 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -442,11 +442,11 @@ (define/private (register-one-blit x y w h on-hbitmap off-hbitmap) (atomically - (let ([hwnd (create-gc-window canvas-hwnd x y w h)]) + (let ([hdc (create-gc-dc canvas-hwnd)]) (let ([r (scheme_add_gc_callback - (make-gc-show-desc hwnd on-hbitmap w h) - (make-gc-hide-desc hwnd off-hbitmap w h))]) - (cons hwnd r))))) + (make-gc-show-desc hdc on-hbitmap x y w h) + (make-gc-hide-desc hdc off-hbitmap x y w h))]) + (cons hdc r))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (let ([on (fix-bitmap-size on w h on-x on-y)] @@ -459,7 +459,7 @@ (define/public (unregister-collecting-blits) (atomically (for ([r (in-list reg-blits)]) - (DestroyWindow (car r)) + (ReleaseDC canvas-hwnd (car r)) (scheme_remove_gc_callback (cdr r))) (set! reg-blits null)))))) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt index 324170cb..e43a2a32 100644 --- a/collects/mred/private/wx/win32/gcwin.rkt +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -7,15 +7,13 @@ (provide scheme_add_gc_callback scheme_remove_gc_callback - create-gc-window + create-gc-dc make-gc-show-desc make-gc-hide-desc) (define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) (define-mz scheme_remove_gc_callback (_fun _racket -> _void)) -(define-user32 ShowWindow/raw _fpointer - #:c-id ShowWindow) (define-gdi32 BitBlt/raw _fpointer #; (_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL) @@ -29,40 +27,18 @@ (define blit-hdc (CreateCompatibleDC #f)) -(define (create-gc-window parent-hwnd x y w h) - (CreateWindowExW 0 - "PLTBlitTarget" - "" - (bitwise-ior WS_CHILD) - x y w h - parent-hwnd - #f - hInstance - #f)) +(define (create-gc-dc hwnd) + (GetDC hwnd)) -(define (make-draw hwnd hbitmap w h) - (let ([hdc (GetDC hwnd)]) - null - (list - (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) - (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void - BitBlt/raw hdc 0 0 w h blit-hdc 0 0 SRCCOPY) - (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f)))) +(define (make-draw hdc hbitmap x y w h) + (vector + (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) + (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void + BitBlt/raw hdc x y w h blit-hdc 0 0 SRCCOPY) + (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f))) -(define (make-gc-show-desc hwnd hbitmap w h) - (list->vector - (append - (list - (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_SHOW)) - (make-draw hwnd hbitmap w h)))) - -(define (make-gc-hide-desc hwnd hbitmap w h) - (list->vector - (append - ;; draw the ``off'' bitmap so it changes immediately: - (make-draw hwnd hbitmap w h) - ;; hide the window; it may take a while for the underlying canvas - ;; to refresh: - (list - (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_HIDE))))) +(define (make-gc-show-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) +(define (make-gc-hide-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index a3ea24fa..2033e2ac 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -58,7 +58,7 @@ _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-cstruct _WNDCLASS ([style _UINT] - [lpfnWndProc _WndProc] + [lpfnWndProc _fpointer] [cbClsExtra _int] [cbWndExtra _int] [hInstace _HINSTANCE] @@ -77,6 +77,8 @@ -> (if r i (failed 'GetClassInfoW)))) (define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 DefWindowProcW/raw _fpointer + #:c-id DefWindowProcW) #;(define-user32 PostQuitMessage (_wfun _int -> _void)) @@ -86,6 +88,8 @@ (send wx wndproc w msg wparam lparam DefWindowProcW) (DefWindowProcW w msg wparam lparam)))) +(define wind-proc-ptr (function-ptr wind-proc _WndProc)) + (define hInstance (GetModuleHandleW #f)) (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) @@ -93,7 +97,7 @@ p)) (void (RegisterClassW (make-WNDCLASS CS_OWNDC - wind-proc + wind-proc-ptr 0 0 hInstance @@ -104,7 +108,7 @@ "PLTFrame"))) (void (RegisterClassW (make-WNDCLASS 0 ; using CS_OWNDC creates trouble when resizing? - wind-proc + wind-proc-ptr 0 0 hInstance @@ -114,19 +118,8 @@ #f ; menu "PLTCanvas"))) -(void (RegisterClassW (make-WNDCLASS CS_OWNDC - DefWindowProcW - 0 - 0 - hInstance - #f - #f - #f - #f - "PLTBlitTarget"))) - (void (RegisterClassW (make-WNDCLASS 0 - wind-proc + wind-proc-ptr 0 0 hInstance @@ -139,7 +132,7 @@ (define controls-are-transparent? #f) (void (RegisterClassW (make-WNDCLASS 0 - wind-proc + wind-proc-ptr 0 0 hInstance From 12e9641d8341f299235fd09e7067661d3c451654 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 10:30:06 -0600 Subject: [PATCH 265/462] fix frame size enforcement and gtk/cocoa positioning original commit: e32475fbbfcf7d33ec911a6890bb34655cf70c4a --- collects/mred/private/mrcanvas.rkt | 2 +- collects/mred/private/mrcontainer.rkt | 9 ++++----- collects/mred/private/mritem.rkt | 2 +- collects/mred/private/mrpanel.rkt | 4 +++- collects/mred/private/mrtop.rkt | 7 ++++--- collects/mred/private/mrwindow.rkt | 13 ++++++------- collects/mred/private/wx/cocoa/frame.rkt | 5 +++++ collects/mred/private/wx/gtk/frame.rkt | 23 +++++++++-------------- collects/mred/private/wx/gtk/window.rkt | 19 +++++++++++-------- 9 files changed, 44 insertions(+), 40 deletions(-) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 2da1e177..2cb7b027 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -91,7 +91,7 @@ (sequence (as-entry (lambda () - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches #f parent #f)))))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches #f parent #f)))))) (define default-paint-cb (lambda (canvas dc) (void))) diff --git a/collects/mred/private/mrcontainer.rkt b/collects/mred/private/mrcontainer.rkt index 44d584c2..c5ff33ee 100644 --- a/collects/mred/private/mrcontainer.rkt +++ b/collects/mred/private/mrcontainer.rkt @@ -42,7 +42,7 @@ [alignment no-val]) (define (make-container% %) ; % implements area<%> - (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches parent ;; for keyword use [border no-val] [spacing no-val] @@ -122,7 +122,7 @@ (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c) (send (get-wx-panel) delete-child (mred->wx c))))]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-wx-outer-pan mismatches parent) (unless (eq? border no-val) (bdr border)) (unless (eq? spacing no-val) (spc spacing)) (unless (eq? alignment no-val) (set-alignment . alignment))))) @@ -131,9 +131,8 @@ (interface (window<%> area-container<%>))) (define (make-area-container-window% %) ; % implements window<%> (and area-container<%>) - (class100* % (area-container-window<%>) (mk-wx get-wx-pan mismatches label parent cursor) - (private-field [get-wx-panel get-wx-pan]) + (class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor) (sequence - (super-init mk-wx get-wx-panel mismatches label parent cursor))))) + (super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor))))) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 6e8fa470..6d2a89f5 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -81,7 +81,7 @@ (sequence (when (string? label) (set! label (string->immutable-string label))) - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches label parent cursor) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches label parent cursor) (unless (hidden-child?) (as-exit (lambda () (send parent after-new-child this))))))) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index b06dc927..ca4c4d79 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -52,7 +52,8 @@ this this (mred->wx-container parent) null #f)) wx) - (lambda () wx) + (lambda () wx) + (lambda () wx) (lambda () (check-container-ready cwho parent)) parent) @@ -96,6 +97,7 @@ (get-initial-label))) wx) (lambda () wx) + (lambda () wx) (lambda () (check-container-ready cwho parent)) #f parent #f) (unless (memq 'deleted style) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index f7a2dc97..f4153ebc 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -49,7 +49,7 @@ (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) - (inherit show set-get-outer-panel) + (inherit show) (rename [super-set-label set-label]) (private [wx-object->proxy @@ -138,8 +138,9 @@ (when status-message (send status-message set-label s)))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor) - (set-get-outer-panel (lambda () mid-panel))))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) + (lambda () wx-panel) (lambda () mid-panel) + mismatches label parent arrow-cursor)))) (define frame% diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 318ae69d..2a4c4a1b 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -42,7 +42,7 @@ set-get-outer-panel) (define area% - (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt + (class100* mred% (area<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches prnt ;; for keyword use: [min-width no-val] [min-height no-val] @@ -54,10 +54,9 @@ (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (mismatches)) (private-field - [get-wx-outer-panel get-wx-pan] + [get-wx-outer-panel get-outer-wx-pan] [parent prnt]) (public - [set-get-outer-panel (lambda (get-wx-outer-pan) (set! get-wx-outer-panel get-wx-outer-pan))] [get-parent (lambda () parent)] [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))] [(minw min-width) (param get-wx-outer-panel min-width)] @@ -88,7 +87,7 @@ [vert-margin no-val]) (define (make-subarea% %) ; % implements area<%> - (class100* % (subarea<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (subarea<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches parent ;; for keyword use [horiz-margin no-val] [vert-margin no-val]) @@ -101,7 +100,7 @@ [(hm horiz-margin) (param get-wx-panel x-margin)] [(vm vert-margin) (param get-wx-panel y-margin)]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-outer-wx-pan mismatches parent) (unless (eq? horiz-margin no-val) (hm horiz-margin)) (unless (eq? vert-margin no-val) (vm vert-margin))))) @@ -125,7 +124,7 @@ (interface (window<%> subarea<%>))) (define (make-window% top? %) ; % implements area<%> - (class100* % (window<%>) (mk-wx get-wx-panel mismatches lbl parent crsr + (class100* % (window<%>) (mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr ;; for keyword use [enabled #t]) (private-field [label lbl][cursor crsr]) @@ -234,5 +233,5 @@ (private-field [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel mismatches parent) + (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent) (unless enabled (enable #f)))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index cd3fbcbb..b575f3bb 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -397,7 +397,12 @@ (+ px (/ (- pw w) 2))) ;; keep current x position: (NSPoint-x (NSRect-origin f))) + ;; keep current y position: (- (NSPoint-y (NSRect-origin f)) + ;; we have to subtract add the titlebar height, for some reason: + (if caption? + (- 22) + 0) (- h (NSSize-height (NSRect-size f))))) (make-NSSize w h)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 3077daae..74153f86 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -133,7 +133,8 @@ pre-on-char pre-on-event get-client-delta get-size get-parent get-eventspace - adjust-client-delta) + adjust-client-delta + queue-on-size) (define gtk (as-gtk-window-allocation (gtk_window_new GTK_WINDOW_TOPLEVEL))) @@ -254,21 +255,15 @@ -11111))))) (define/public (set-top-position x y) - (when (and (vector? saved-enforcements) - (or (x . < . (vector-ref saved-enforcements 0)) - (let ([max-x (vector-ref saved-enforcements 1)]) - (and (max-x . > . -1) (x . > . max-x))) - (y . < . (vector-ref saved-enforcements 2)) - (let ([max-y (vector-ref saved-enforcements 3)]) - (and (max-y . > . -1) (y . > . max-y))))) - (enforce-size 0 0 -1 -1 1 1)) - (gtk_widget_set_uposition gtk - (if (= x -11111) -2 x) - (if (= y -11111) -2 y))) + (unless (and (= x -11111) (= y -11111)) + (gtk_widget_set_uposition gtk + (if (= x -11111) -2 x) + (if (= y -11111) -2 y)))) - (define/override (really-set-size gtk x y w h) + (define/override (really-set-size gtk x y processed-x processed-y w h) (set-top-position x y) - (gtk_window_resize gtk (max 1 w) (max 1 h))) + (gtk_window_resize gtk (max 1 w) (max 1 h)) + (queue-on-size)) (define/override (show on?) (let ([es (get-eventspace)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 85a05333..36ef33f2 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -416,31 +416,34 @@ (unless (= h -1) (set! save-h h)) (set! save-w (max save-w client-delta-w)) (set! save-h (max save-h client-delta-h)) - (really-set-size gtk save-x save-y save-w save-h))) + (really-set-size gtk x y save-x save-y save-w save-h))) (define/public (save-size x y w h) (set! save-w w) (set! save-h h)) - (define/public (really-set-size gtk x y w h) + (define/public (really-set-size gtk given-x given-y x y w h) (send parent set-child-size gtk x y w h)) (define/public (set-child-size child-gtk x y w h) (gtk_widget_set_size_request child-gtk w h) (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) - (define on-size-queued? #f) (define/public (remember-size w h) ;; called in event-pump thread (unless (and (= save-w w) (= save-h h)) (set! save-w w) (set! save-h h) - (unless on-size-queued? - (set! on-size-queued? #t) - (queue-window-event this (lambda () - (set! on-size-queued? #f) - (on-size w h)))))) + (queue-on-size))) + + (define on-size-queued? #f) + (define/public (queue-on-size) + (unless on-size-queued? + (set! on-size-queued? #t) + (queue-window-event this (lambda () + (set! on-size-queued? #f) + (on-size 0 0))))) (define client-delta-w 0) (define client-delta-h 0) From 981252ade9ce3c341f8e686fe236759fcf8c62bd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 10:47:16 -0600 Subject: [PATCH 266/462] win32: enforce frame constraints when resizing original commit: a19a67e51582be250397becac2c2788af1123a32 --- collects/mred/private/wx/win32/frame.rkt | 42 +++++++++++++++++++++--- 1 file changed, 38 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index fc336ffd..6f0aa1d8 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -31,7 +31,11 @@ (define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL) -> (unless r (failed 'SystemParametersInfo)))) - +(define-cstruct _MINMAXINFO ([ptReserved _POINT] + [ptMaxSize _POINT] + [ptMaxPosition _POINT] + [ptMinTrackSize _POINT] + [ptMaxTrackSize _POINT])) (define SPI_GETWORKAREA #x0030) @@ -108,6 +112,11 @@ (define saved-title (or label "")) (define hidden-zoomed? #f) + (define min-width #f) + (define min-height #f) + (define max-width #f) + (define max-height #f) + (super-new [parent #f] [hwnd (create-frame parent label w h style)] [style (cons 'invisible style)]) @@ -174,8 +183,30 @@ (lambda () (on-menu-click)) (void)) 0] + [(= msg WM_GETMINMAXINFO) + (let ([mmi (cast lParam _LPARAM _MINMAXINFO-pointer)]) + (when (or max-width max-height) + (set-MINMAXINFO-ptMaxTrackSize! + mmi + (make-POINT (or max-width + (POINT-x (MINMAXINFO-ptMaxTrackSize mmi))) + (or max-height + (POINT-y (MINMAXINFO-ptMaxTrackSize mmi)))))) + (when (or min-width min-height) + (set-MINMAXINFO-ptMinTrackSize! + mmi + (make-POINT (or min-width + (POINT-x (MINMAXINFO-ptMinTrackSize mmi))) + (or min-height + (POINT-y (MINMAXINFO-ptMinTrackSize mmi))))))) + 0] [else (super wndproc w msg wParam lParam default)])) + (define/override (set-size x y w h) + (unless (and (= w -1) (= h -1)) + (maximize #f)) + (super set-size x y w h)) + (define/public (on-close) (void)) (define/override (is-shown-to-root?) @@ -196,7 +227,10 @@ (def/public-unimplemented on-mdi-activate) (define/public (enforce-size min-x min-y max-x max-y step-x step-y) - (void)) + (set! min-width (max 1 min-x)) + (set! min-height (max 1 min-y)) + (set! max-width (and (positive? max-x) max-x)) + (set! max-height (and (positive? max-y) max-y))) (define focus-window-path #f) (define/override (not-focus-child v) @@ -312,10 +346,10 @@ (define/public (maximize on?) (if (is-shown?) - (set! hidden-zoomed? (and on? #t)) (ShowWindow hwnd (if on? SW_MAXIMIZE - SW_RESTORE)))) + SW_RESTORE)) + (set! hidden-zoomed? (and on? #t)))) (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) From d2458f567dc200184a36fa3c360777a664f0d19a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 13:55:32 -0600 Subject: [PATCH 267/462] gtk: fix delete key original commit: 9c15da955d1f33d6b8fccf18656df1bd830e309b --- collects/mred/private/wx/gtk/keycode.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt index e4e56935..9830dfa7 100644 --- a/collects/mred/private/wx/gtk/keycode.rkt +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -5,6 +5,7 @@ (define (map-key-code v) (hash-ref #hash((#xff08 . #\backspace) + (#xffff . #\rubout) (#xff09 . #\tab) (#xff0a . #\newline) (#xff0d . #\return) From d7afaed8698a6d634a51c0d59d9f14804fa22b19 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 14:27:01 -0600 Subject: [PATCH 268/462] gtk: fix clipboard string content original commit: b843078284c16bada31356b75ae8f4c56e22153e --- collects/mred/private/wx/gtk/clipboard.rkt | 23 ++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 13bdb2b8..fc25fa0c 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -94,16 +94,20 @@ ;; In clipboard mode (as opposed to X selection), we can get the data ;; now, so it's ready if anyone asks: (let ([all-data (for/list ([t (in-list types)]) - (send c get-data t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) (apply + (map string-utf-8-length types))))] + (send c get-data t))] + [types (for/list ([t (in-list types)]) + (if (equal? t "TEXT") + "UTF8_STRING" + t))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) - ([str (in-list types)] - [i (in-naturals)]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t i) - (set-GtkTargetEntry-info! t 0)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) (let ([bstr (string->bytes/utf-8 str)]) (memcpy target-strings offset bstr 0 (bytes-length bstr)) (let ([offset (+ offset (bytes-length bstr))]) @@ -158,7 +162,10 @@ (gtk_selection_data_get_length v) 1)]) (gtk_selection_data_free v) - bstr)))]) + bstr)))] + [format (if (equal? format "TEXT") + "UTF8_STRING" + format)]) (process (gtk_clipboard_wait_for_contents cb (gdk_atom_intern format #t))))) (define/public (get-text-data) From 7dd75533793f7708aa4d0c8da1090438a12906f5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 07:53:38 -0600 Subject: [PATCH 269/462] win32: misc repairs original commit: d4f7df6eb88d235e58fc54502acfdcbeb081132c --- collects/mred/private/wx/cocoa/procs.rkt | 4 -- collects/mred/private/wx/gtk/procs.rkt | 4 -- collects/mred/private/wx/win32/button.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 4 ++ collects/mred/private/wx/win32/dc.rkt | 24 +++++++---- collects/mred/private/wx/win32/frame.rkt | 32 +++++++++++++- .../mred/private/wx/win32/group-panel.rkt | 1 + collects/mred/private/wx/win32/hbitmap.rkt | 43 +++++++++++++------ collects/mred/private/wx/win32/procs.rkt | 24 ++++++----- collects/mred/private/wx/win32/window.rkt | 3 +- 10 files changed, 96 insertions(+), 45 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 267be1c3..9734d1d4 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -47,8 +47,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -108,8 +106,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define (id-to-menu-item id) id) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index a59ced41..7c5dcfd9 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -45,8 +45,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -103,8 +101,6 @@ (define-unimplemented is-color-display?) (define (id-to-menu-item i) i) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 80901867..88a153f3 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -54,7 +54,7 @@ (when bitmap? (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM))) (set-control-font font) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index f3b6c0c3..931ba4b2 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -278,6 +278,10 @@ (send col green) (send col blue))))) + (define wants-focus? (not (memq 'no-focus style))) + (define/override (can-accept-focus?) + wants-focus?) + (define h-scroll-visible? hscroll?) (define v-scroll-visible? vscroll?) (define/public (show-scrollbars h? v?) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 3fd63e7d..efdd082b 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -13,6 +13,7 @@ ffi/unsafe/alloc) (provide dc% + win32-bitmap% do-backing-flush request-flush-delay cancel-flush-delay) @@ -23,14 +24,21 @@ (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if (not hwnd) - (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) - (atomically - (let ([hdc (GetDC hwnd)]) - (begin0 - (cairo_win32_surface_create_with_ddb hdc - CAIRO_FORMAT_RGB24 w h) - (ReleaseDC hwnd hdc)))))) + (let ([s + (if (not hwnd) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC hwnd)]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hwnd hdc)))))]) + ;; initialize bitmap to white: + (let ([cr (cairo_create s)]) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + s)) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 6f0aa1d8..3a49cc3e 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/class + racket/draw (only-in racket/list last) ffi/unsafe "../../syntax.rkt" @@ -12,6 +13,7 @@ "theme.rkt" "window.rkt" "wndclass.rkt" + "hbitmap.rkt" "cursor.rkt") (provide frame% @@ -37,6 +39,14 @@ [ptMinTrackSize _POINT] [ptMaxTrackSize _POINT])) +(define-cstruct _ICONINFO ([fIcon _BOOL] + [xHotspot _DWORD] + [yHotspot _DWORD] + [hbmMask _HBITMAP] + [hbmColor _HBITMAP])) +(define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON) + -> (or r (failed 'CreateIconIndirect)))) + (define SPI_GETWORKAREA #x0030) (define (display-size xb yb ?) @@ -119,7 +129,7 @@ (super-new [parent #f] [hwnd (create-frame parent label w h style)] - [style (cons 'invisible style)]) + [style (cons 'deleted style)]) (define hwnd (get-hwnd)) (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) @@ -148,6 +158,9 @@ SW_SHOWMAXIMIZED SW_SHOW))) + (define/public (destroy) + (direct-show #f)) + (define/private (stdret f d) (if (is-dialog?) d f)) @@ -366,7 +379,22 @@ (define/override (is-frame?) #t) (define/public (set-icon bm mask [mode 'both]) - (void)) + (let ([hicon (CreateIconIndirect + (make-ICONINFO + #t 0 0 + (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send dc set-bitmap #f) + (bitmap->hbitmap bm #:b&w? #t)) + (bitmap->hbitmap bm #:mask mask)))]) + (when (or (eq? mode 'small) + (eq? mode 'both)) + (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM))) + (when (or (eq? mode 'big) + (eq? mode 'both)) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM))))) (def/public-unimplemented iconize) (define/public (set-title s) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 8fe5c030..3d7e7ff2 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -49,6 +49,7 @@ (super-new [callback void] [parent parent] [hwnd hwnd] + [extra-hwnds (list client-hwnd)] [style style]) (define/override (get-client-hwnd) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index fe9aea80..b4e0952f 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -11,37 +11,52 @@ (provide bitmap->hbitmap) (define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) +(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP)) (define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) -> (unless r (failed 'DeleteDC)))) -(define (bitmap->hbitmap bm) +(define (bitmap->hbitmap bm + #:mask [mask-bm #f] + #:b&w? [b&w? #f] + #:bg [bg (GetSysColor COLOR_BTNFACE)]) (let* ([w (send bm get-width)] [h (send bm get-height)] - [col (GetSysColor COLOR_BTNFACE)] + [mask-bm (or mask-bm + (send bm get-loaded-mask))] [to-frac (lambda (v) (/ v 255.0))] [screen-hdc (GetDC #f)] [hdc (CreateCompatibleDC screen-hdc)] - [hbitmap (CreateCompatibleBitmap screen-hdc w h)] + [hbitmap (if b&w? + (CreateBitmap w h 1 1 #f) + (CreateCompatibleBitmap screen-hdc w h))] [old-hbitmap (SelectObject hdc hbitmap)]) (ReleaseDC #f screen-hdc) (let* ([s (cairo_win32_surface_create hdc)] [cr (cairo_create s)]) (cairo_surface_destroy s) (cairo_set_source_rgba cr - (to-frac (GetRValue col)) - (to-frac (GetGValue col)) - (to-frac (GetBValue col)) + (to-frac (GetRValue bg)) + (to-frac (GetGValue bg)) + (to-frac (GetBValue bg)) 1.0) (cairo_paint cr) - (let ([p (cairo_get_source cr)]) - (cairo_pattern_reference p) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 w h) - (cairo_fill cr) - (cairo_set_source cr p) - (cairo_pattern_destroy p)) + (let ([mask-p (and mask-bm + (cairo_pattern_create_for_surface + (send mask-bm get-cairo-alpha-surface)))]) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (if mask-p + (cairo_mask cr mask-p) + (begin + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr))) + (when mask-p + (cairo_pattern_destroy mask-p)) + (cairo_set_source cr p) + (cairo_pattern_destroy p))) (cairo_destroy cr) (SelectObject hdc old-hbitmap) (DeleteDC hdc) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 6e191c5f..e2a4e761 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -8,6 +8,7 @@ "const.rkt" "menu-item.rkt" "frame.rkt" + "dc.rkt" racket/draw) (provide @@ -41,8 +42,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -54,7 +53,11 @@ (define-unimplemented special-option-key) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) -(define (get-panel-background) (make-object color% "gray")) + +(define (get-panel-background) + (let ([c (GetSysColor COLOR_BTNFACE)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) @@ -74,18 +77,17 @@ (define (flush-display) (void)) (define-unimplemented write-resource) (define-unimplemented get-resource) -(define-unimplemented bell) + +(define-user32 MessageBeep (_wfun _UINT -> _BOOL)) +(define (bell) + (void (MessageBeep MB_OK))) (define (hide-cursor) (void)) -(define-unimplemented end-busy-cursor) -(define-unimplemented is-busy?) -(define-unimplemented begin-busy-cursor) (define (get-display-depth) 32) + (define-unimplemented is-color-display?) (define-unimplemented file-selector) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) @@ -96,6 +98,8 @@ (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) -(define-unimplemented make-screen-bitmap) +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (make-object win32-bitmap% w h #f)) (define (check-for-break) #f) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 06d37e61..f7cc9df2 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -183,7 +183,7 @@ (register-child-in-parent on?) (unless on? (not-focus-child this)) (ShowWindow hwnd (if on? on-mode SW_HIDE))) - (unless (memq 'invisible style) + (unless (memq 'deleted style) (show #t)) (def/public-unimplemented on-drop-file) @@ -256,7 +256,6 @@ (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) #t)) (MoveWindow hwnd x y w h #t)) - (on-size w h) (unless (and (= w -1) (= h -1)) (on-resized)) (refresh)) From a153f1ab6a38447dbef34af387ca43b90aad5005 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 08:00:14 -0600 Subject: [PATCH 270/462] gtk: fix get-directory dialog original commit: 905594ced3e27eea3b81616c34257482f8576585 --- collects/mred/private/wx/gtk/filedialog.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt index 535ae829..6423f7e9 100644 --- a/collects/mred/private/wx/gtk/filedialog.rkt +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -72,7 +72,7 @@ (define dlg (gtk_file_chooser_dialog_new message (and parent (send parent get-gtk)) (case type - [(dir) 'select-directory] + [(dir) 'select-folder] [(put) 'save] [else 'open]) "gtk-cancel" 'cancel From 6793ac1655f0be2503fa5a1688230d8806bb4e13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 13:39:32 -0600 Subject: [PATCH 271/462] win32: memory management original commit: 3f3d5f0f2131293bb3d4fff886158bd34c6cfdae --- collects/mred/private/wx/win32/button.rkt | 9 ++-- collects/mred/private/wx/win32/canvas.rkt | 11 ++--- collects/mred/private/wx/win32/frame.rkt | 45 ++++++++++++++------ collects/mred/private/wx/win32/gcwin.rkt | 2 - collects/mred/private/wx/win32/hbitmap.rkt | 6 --- collects/mred/private/wx/win32/item.rkt | 5 +++ collects/mred/private/wx/win32/message.rkt | 11 +++-- collects/mred/private/wx/win32/radio-box.rkt | 9 ++-- collects/mred/private/wx/win32/utils.rkt | 43 +++++++++++++++++-- collects/mred/private/wx/win32/window.rkt | 5 +++ collects/mred/private/wx/win32/wndclass.rkt | 6 +++ 11 files changed, 111 insertions(+), 41 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 88a153f3..75639f4c 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -20,7 +20,8 @@ (define base-button% (class item% (inherit set-control-font auto-size get-hwnd - subclass-control) + subclass-control + remember-label-bitmap) (init parent cb label x y w h style font) @@ -53,8 +54,10 @@ [style style]) (when bitmap? - (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label #:bg #xFFFFFF)]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (set-control-font font) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 931ba4b2..eb374ca6 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -31,14 +31,9 @@ -> (unless r (failed 'ShowScrollbar)))) (define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) -(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) - -> (unless r (failed 'DeleteObject)))) (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) -(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) - -> (unless r (failed 'DestroyWindow)))) - (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -89,7 +84,8 @@ subclass-control is-auto-scroll? get-virtual-width get-virtual-height reset-auto-scroll - refresh-for-autoscroll) + refresh-for-autoscroll + on-size) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) @@ -228,7 +224,8 @@ [w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)] [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) - (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))) + (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))) + (on-size 0 0)) ;; The `queue-paint' and `paint-children' methods ;; are defined by `canvas-mixin' from ../common/canvas-mixin diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 3a49cc3e..8bc64a74 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -3,6 +3,7 @@ racket/draw (only-in racket/list last) ffi/unsafe + ffi/unsafe/alloc "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" @@ -44,8 +45,13 @@ [yHotspot _DWORD] [hbmMask _HBITMAP] [hbmColor _HBITMAP])) + +(define-user32 DestroyIcon (_wfun _HICON -> (r : _BOOL) + -> (unless r (failed 'DestroyIcon))) + #:wrap (deallocator)) (define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON) - -> (or r (failed 'CreateIconIndirect)))) + -> (or r (failed 'CreateIconIndirect))) + #:wrap (allocator DestroyIcon)) (define SPI_GETWORKAREA #x0030) @@ -378,23 +384,36 @@ (define/override (is-frame?) #t) + ;; Retain to aviod GC of the icon: + (define small-hicon #f) + (define big-hicon #f) + (define/public (set-icon bm mask [mode 'both]) - (let ([hicon (CreateIconIndirect - (make-ICONINFO - #t 0 0 - (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] - [dc (make-object bitmap-dc% bm)]) - (send dc set-brush "black" 'solid) - (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) - (send dc set-bitmap #f) - (bitmap->hbitmap bm #:b&w? #t)) - (bitmap->hbitmap bm #:mask mask)))]) + (let* ([bg-hbitmap + (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send dc set-bitmap #f) + (bitmap->hbitmap bm #:b&w? #t))] + [main-hbitmap (bitmap->hbitmap bm #:mask mask)] + [hicon (CreateIconIndirect + (make-ICONINFO + #t 0 0 + bg-hbitmap + main-hbitmap))]) + (DeleteObject bg-hbitmap) + (DeleteObject main-hbitmap) (when (or (eq? mode 'small) (eq? mode 'both)) - (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM))) + (atomically + (set! small-hicon hicon) + (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM)))) (when (or (eq? mode 'big) (eq? mode 'both)) - (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM))))) + (atomically + (set! big-hicon hicon) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))) (def/public-unimplemented iconize) (define/public (set-title s) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt index e43a2a32..7f84bdcc 100644 --- a/collects/mred/private/wx/win32/gcwin.rkt +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -21,8 +21,6 @@ (define-gdi32 SelectObject/raw _fpointer #:c-id SelectObject) -(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) - (define SRCCOPY #x00CC0020) (define blit-hdc (CreateCompatibleDC #f)) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index b4e0952f..81e327c5 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -10,12 +10,6 @@ (provide bitmap->hbitmap) -(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) -(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP)) -(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) -(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) - -> (unless r (failed 'DeleteDC)))) - (define (bitmap->hbitmap bm #:mask [mask-bm #f] #:b&w? [b&w? #f] diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 6f8491ff..a74d0cd6 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -76,6 +76,11 @@ (super-new) (define/override (gets-focus?) #t) + + ;; Retain to avoid GC of the bitmaps: + (define label-hbitmaps null) + (define/public (remember-label-bitmap hbitmap) + (set! label-hbitmaps (cons hbitmap label-hbitmaps))) (define/public (set-label s) (SetWindowTextW (get-hwnd) s)) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index a0af26ea..2572c55b 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -64,7 +64,8 @@ (define message% (class item% (inherit auto-size set-size set-control-font get-hwnd - subclass-control) + subclass-control + remember-label-bitmap) (init parent label x y @@ -100,8 +101,10 @@ (subclass-control (get-hwnd)) (when bitmap? - (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label)]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (when (symbol? label) (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON (cast (force (case label @@ -111,7 +114,7 @@ _HICON _LPARAM))) (set-control-font font) - + (if (symbol? label) (set-size -11111 -11111 32 32) (auto-size label 0 0 0 0)))) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 583b246e..41db4c26 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -30,7 +30,8 @@ (inherit auto-size set-control-font is-enabled-to-root? subclass-control - set-focus) + set-focus + remember-label-bitmap) (define callback cb) (define current-value val) @@ -71,8 +72,10 @@ hInstance #f)]) (when bitmap? - (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (let ([hbitmap (bitmap->hbitmap label)]) + (remember-label-bitmap hbitmap) + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) (ShowWindow radio-hwnd SW_SHOW) (set-control-font font radio-hwnd) (let-values ([(w h) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 273cca8a..25d4cb81 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define + ffi/unsafe/alloc "../common/utils.rkt" "types.rkt") @@ -14,11 +15,18 @@ failed GetLastError + DestroyWindow + NotifyWindowDestroy CreateWindowExW GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str GetSysColor GetRValue GetGValue GetBValue make-COLORREF + CreateBitmap + CreateCompatibleBitmap + DeleteObject + CreateCompatibleDC + DeleteDC MoveWindow ShowWindow EnableWindow @@ -53,13 +61,20 @@ (error who "call failed (~s)" (GetLastError))) +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow))) + #:wrap (deallocator)) +(define NotifyWindowDestroy ((deallocator) void)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 _UDWORD _int _int _int _int _HWND _HMENU _HINSTANCE _pointer - -> _HWND)) + -> _HWND) + #:wrap (allocator DestroyWindow)) + (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) @@ -88,8 +103,30 @@ (define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR)) -(define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) +(define-user32 _GetDC (_wfun _HWND -> _HDC) + #:c-id GetDC) +(define (GetDC hwnd) + (((allocator (lambda (hdc) (ReleaseDC hwnd hdc))) + _GetDC) + hwnd)) + +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int) + #:wrap (deallocator cadr)) + +(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) + -> (unless r (failed 'DeleteObject))) + #:wrap (deallocator)) + +(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP) + #:wrap (allocator DeleteObject)) +(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP) + #:wrap (allocator DeleteObject)) + +(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) + -> (unless r (failed 'DeleteDC))) + #:wrap (deallocator)) +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC) + #:wrap (allocator DeleteDC)) (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) -> (unless r (failed 'InvalidateRect)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index f7cc9df2..b231db0b 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -114,6 +114,11 @@ (if (try-mouse w msg wParam lParam) 0 (cond + [(= msg WM_DESTROY) + ;; release immobile cell + (unregister-hwnd w) + ;; so it won't be finalized: + (NotifyWindowDestroy w)] [(= msg WM_SETFOCUS) (queue-window-event this (lambda () (on-set-focus))) 0] diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 2033e2ac..d789de66 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -13,6 +13,7 @@ hwnd->wx any-hwnd->wx set-hwnd-wx! + unregister-hwnd MessageBoxW _WndProc) @@ -38,6 +39,11 @@ (send wx is-hwnd? hwnd) wx))))) +(define (unregister-hwnd hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (when p + (free-immobile-cell p) + (SetWindowLongW hwnd GWLP_USERDATA #f)))) ;; ---------------------------------------- From d554cde30f163d310b87329b2154b7444115c43b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 15:32:41 -0600 Subject: [PATCH 272/462] win32: set-label with bitmaps original commit: 80ce36d30d85ed643dd4c02648ba8e728ad5fd51 --- collects/mred/private/wx/win32/item.rkt | 17 ++++++++++++++--- collects/mred/private/wx/win32/message.rkt | 8 ++++++-- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index a74d0cd6..0ebbc88a 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -2,8 +2,9 @@ (require racket/class racket/draw ffi/unsafe - "../../syntax.rkt" - "../common/event.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" "utils.rkt" "const.rkt" "window.rkt" @@ -83,7 +84,17 @@ (set! label-hbitmaps (cons hbitmap label-hbitmaps))) (define/public (set-label s) - (SetWindowTextW (get-hwnd) s)) + (if (s . is-a? . bitmap%) + (let ([hbitmap (bitmap->hbitmap s)]) + (atomically + (set! label-hbitmaps (list hbitmap)) + (SendMessageW (get-hwnd) + (get-setimage-message) + IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + (SetWindowTextW (get-hwnd) s))) + + (define/public (get-setimage-message) BM_SETIMAGE) (def/public-unimplemented get-label))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 2572c55b..de6cccdc 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -105,6 +105,7 @@ (remember-label-bitmap hbitmap) (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP (cast hbitmap _HBITMAP _LPARAM)))) + (when (symbol? label) (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON (cast (force (case label @@ -114,7 +115,10 @@ _HICON _LPARAM))) (set-control-font font) - + (if (symbol? label) (set-size -11111 -11111 32 32) - (auto-size label 0 0 0 0)))) + (auto-size label 0 0 0 0)) + + (define/override (get-setimage-message) + STM_SETIMAGE))) From e29c9457e4844a20d80420b7f2aad6466fe2694d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 16:17:09 -0600 Subject: [PATCH 273/462] win32: control callback fixes original commit: fbc8d174132fbc0fa991c07677dbdd5763566d4c --- collects/mred/private/wx/win32/button.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 2 +- collects/mred/private/wx/win32/choice.rkt | 23 +++++++++- collects/mred/private/wx/win32/list-box.rkt | 19 +++++++++ collects/mred/private/wx/win32/radio-box.rkt | 2 +- collects/mred/private/wx/win32/tab-panel.rkt | 2 +- collects/mred/private/wx/win32/window.rkt | 44 ++++++++++---------- 7 files changed, 67 insertions(+), 27 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 75639f4c..a8581ac2 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -74,7 +74,7 @@ (define/override (is-command? cmd) (= cmd BN_CLICKED)) - (define/public (do-command control-hwnd) + (define/public (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index eb374ca6..24722e4c 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -418,7 +418,7 @@ (define/override (is-command? cmd) (= cmd CBN_SELENDOK)) - (define/public (do-command control-hwnd) + (define/public (do-command cmd control-hwnd) (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) (queue-window-event this (lambda () (on-combo-select i))))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 2526a8d8..a9de92b2 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -14,6 +14,10 @@ (provide choice%) +(define CBN_DROPDOWN 7) +(define CBN_CLOSEUP 8) +(define CBN_SELENDCANCEL 10) + (define choice% (class item% (init parent cb label @@ -62,10 +66,27 @@ (subclass-control hwnd) + (define choice-dropped? #f) + + (define/override (ctlproc w msg wParam lParam default) + (cond + [(and choice-dropped? + (or (= msg WM_KEYDOWN) + (= msg WM_KEYUP) + (= msg WM_SYSCHAR) + (= msg WM_CHAR))) + (default w msg wParam lParam)] + [else (super ctlproc w msg wParam lParam default)])) + (define/override (is-command? cmd) + (when (= cmd CBN_DROPDOWN) + (set! choice-dropped? #t)) + (when (= cmd CBN_CLOSEUP) + (queue-window-event this (lambda () + (set! choice-dropped? #f)))) (= cmd CBN_SELENDOK)) - (define/public (do-command control-hwnd) + (define/public (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 20a57602..ba12082f 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -25,6 +25,9 @@ (define LBS_EXTENDEDSEL #x0800) (define LBS_DISABLENOSCROLL #x1000) +(define LBN_SELCHANGE 1) +(define LBN_DBLCLK 2) + (define LB_ERR -1) (define LB_ADDSTRING #x0180) @@ -88,6 +91,22 @@ (subclass-control hwnd) + (define callback cb) + + (define/override (is-command? cmd) + (or (= cmd LBN_SELCHANGE) + (= cmd LBN_DBLCLK))) + + (define/public (do-command cmd control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type (if (= cmd LBN_SELCHANGE) + 'list-box + 'list-box-dclick)] + [time-stamp (current-milliseconds)]))))) + + (define num (length choices)) (define/public (number) num) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 41db4c26..926f685c 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -105,7 +105,7 @@ (define/override (is-command? cmd) (= cmd BN_CLICKED)) - (define/public (do-command control-hwnd) + (define/public (do-command cmd control-hwnd) (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)] [pos (in-naturals)]) (if (ptr-equal? control-hwnd radio-hwnd) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 23e36a79..9e01b259 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -115,7 +115,7 @@ (define/override (is-command? cmd) (= cmd 64985)) - (define/public (do-command control-hwnd) + (define/public (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index b231db0b..24a00f02 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -132,33 +132,32 @@ (default w msg wParam lParam) (do-key w msg wParam lParam #f #f))] [(= msg WM_KEYDOWN) - (do-key w msg wParam lParam #f #f) - 0] + (do-key w msg wParam lParam #f #f default)] [(= msg WM_KEYUP) - (do-key w msg wParam lParam #f #t) - 0] + (do-key w msg wParam lParam #f #t default)] [(and (= msg WM_SYSCHAR) (= wParam VK_MENU)) (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w msg wParam lParam #t #f))] + (do-key w msg wParam lParam #t #f void))] [(= msg WM_CHAR) - (do-key w msg wParam lParam #t #f) - 0] + (do-key w msg wParam lParam #t #f default)] [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] - [wx (any-hwnd->wx control-hwnd)]) - (if (and wx (send wx is-command? (HIWORD wParam))) + [wx (any-hwnd->wx control-hwnd)] + [cmd (HIWORD wParam)]) + (if (and wx (send wx is-command? cmd)) (begin - (send wx do-command control-hwnd) + (send wx do-command cmd control-hwnd) 0) (default w msg wParam lParam)))] [(= msg WM_NOTIFY) (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] [control-hwnd (NMHDR-hwndFrom nmhdr)] - [wx (any-hwnd->wx control-hwnd)]) - (if (and wx (send wx is-command? (LOWORD (NMHDR-code nmhdr)))) + [wx (any-hwnd->wx control-hwnd)] + [cmd (LOWORD (NMHDR-code nmhdr))]) + (if (and wx (send wx is-command? cmd)) (begin (send wx do-command control-hwnd) 0) @@ -398,17 +397,18 @@ (define/public (get-top-frame) (send parent get-top-frame)) - (define/private (do-key w msg wParam lParam is-char? is-up?) + (define/private (do-key w msg wParam lParam is-char? is-up? default) (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) - (and e - (if (definitely-wants-event? w msg wParam e) - (begin - (queue-window-event this (lambda () (dispatch-on-char/sync e))) - #t) - (constrained-reply (get-eventspace) - (lambda () (dispatch-on-char e #t)) - #t))))) - + (if (and e + (if (definitely-wants-event? w msg wParam e) + (begin + (queue-window-event this (lambda () (dispatch-on-char/sync e))) + #t) + (constrained-reply (get-eventspace) + (lambda () (dispatch-on-char e #t)) + #t))) + 0 + (default w msg wParam lParam)))) (define/public (try-mouse w msg wParam lParam) (cond From d36e3da8be2a9f15cb687f72217c953b207167cf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 19:43:28 -0600 Subject: [PATCH 274/462] win32: file dialog original commit: 7ffff49507231bad77715aecdfec51eb4b9ed2e4 --- collects/mred/private/wx/win32/dialog.rkt | 2 - collects/mred/private/wx/win32/filedialog.rkt | 225 ++++++++++++++++++ collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/types.rkt | 19 +- collects/mred/private/wx/win32/utils.rkt | 3 + 5 files changed, 243 insertions(+), 8 deletions(-) create mode 100644 collects/mred/private/wx/win32/filedialog.rkt diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index 3a5537d6..b3e8a887 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -16,8 +16,6 @@ (provide dialog%) -(define _WORD _short) - (define-cstruct _DLGTEMPLATE ([style _DWORD] [dwExtendedStyle _DWORD] diff --git a/collects/mred/private/wx/win32/filedialog.rkt b/collects/mred/private/wx/win32/filedialog.rkt new file mode 100644 index 00000000..c49b225e --- /dev/null +++ b/collects/mred/private/wx/win32/filedialog.rkt @@ -0,0 +1,225 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/string + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../../lock.rkt") + +(provide file-selector) + +(define-cstruct _OPENFILENAME + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hInstance _HINSTANCE] + [lpstrFilter _permanent-string/utf-16] + [lpstrCustomFilter _permanent-string/utf-16] + [nMaxCustFilter _DWORD] + [nFilterIndex _DWORD] + [lpstrFile _pointer] + [nMaxFile _DWORD] + [lpstrFileTitle _pointer] + [nMaxFileTitle _DWORD] + [lpstrInitialDir _permanent-string/utf-16] + [lpstrTitle _permanent-string/utf-16] + [Flags _DWORD] + [nFileOffset _WORD] + [nFileExtension _WORD] + [lpstrDefExt _permanent-string/utf-16] + [lCustData _LPARAM] + [lpfnHook _fpointer] + [lpTemplateName _permanent-string/utf-16] + [pvReserved _pointer] + [dwReserved _DWORD] + [FlagsEx _DWORD])) + +(define-comdlg32 GetSaveFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) +(define-comdlg32 GetOpenFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) + +(define OFN_READONLY #x00000001) +(define OFN_OVERWRITEPROMPT #x00000002) +(define OFN_HIDEREADONLY #x00000004) +(define OFN_NOCHANGEDIR #x00000008) +(define OFN_SHOWHELP #x00000010) +(define OFN_ENABLEHOOK #x00000020) +(define OFN_ENABLETEMPLATE #x00000040) +(define OFN_ENABLETEMPLATEHANDLE #x00000080) +(define OFN_ALLOWMULTISELECT #x00000200) +(define OFN_EXTENSIONDIFFERENT #x00000400) +(define OFN_PATHMUSTEXIST #x00000800) +(define OFN_FILEMUSTEXIST #x00001000) +(define OFN_NOREADONLYRETURN #x00008000) +(define OFN_EXPLORER #x00080000) + +(define BUFFER-LEN 4096) + +(define-cstruct _BROWSEINFO + ([hwndOwner _HWND] + [pidlRoot _pointer] + [pszDisplayName _pointer] + [lpszTitle _permanent-string/utf-16] + [ulFlags _UINT] + [lpfn _pointer] + [lParam _LPARAM] + [iImage _int])) + +(define BIF_RETURNONLYFSDIRS #x00000001) +(define BIF_NEWDIALOGSTYLE #x00000040) + +(define-cstruct _IUnknownVtbl + ([QueryInterface _fpointer] + [AddRef _fpointer] + [Release (_wfun _pointer -> _ULONG)])) + +(define-cstruct (_IMallocVtbl _IUnknownVtbl) + ([Alloc _fpointer] + [Realloc _fpointer] + [Free (_wfun _pointer _pointer -> _void)] + [GetSize _fpointer] + [DidAlloc _fpointer] + [HeapMinimize _fpointer])) + +(define-cstruct _IMalloc + ([vtbl _IMallocVtbl-pointer])) + +(define (IMalloc-Free im p) + ((IMallocVtbl-Free (IMalloc-vtbl im)) im p)) +(define (IMalloc-Release im) + ((IUnknownVtbl-Release (IMalloc-vtbl im)) im)) + +(define-shell32 SHBrowseForFolderW (_wfun _BROWSEINFO-pointer -> _pointer)) +(define-shell32 SHGetPathFromIDListW (_wfun _pointer _pointer -> _BOOL)) +(define-shell32 SHGetMalloc (_wfun (p : (_ptr o _IMalloc-pointer)) -> (r : _HRESULT) + -> (if (negative? r) + (error 'SHGetMalloc "failed: ~s" (bitwise-and #xFFFF r)) + p))) + +(define (file-selector message directory filename + extension + filters style parent) + (if (memq 'dir style) + (dialog-selector message directory + style parent) + (do-file-selector message directory filename + extension + filters style parent))) + +(define (do-file-selector message directory filename + extension + filters style parent) + (atomically + (let* ([pre-ofn + (make-OPENFILENAME + (ctype-sizeof _OPENFILENAME) + (and parent + (send parent get-hwnd)) + hInstance + (string-append + (string-join + (for/list ([f (in-list filters)]) + (format "~a\0~a" (car f) (cadr f))) + "\0") + "\0") + #f + 0 + 0 ; nFilterIndex + (malloc 'raw (* BUFFER-LEN (ctype-sizeof _short))) + BUFFER-LEN + #f + 0 + (and directory + (path->string (simplify-path directory #f))) + message + (bitwise-ior + OFN_HIDEREADONLY + (if (memq 'put style) OFN_OVERWRITEPROMPT 0) + (if (memq 'multi style) (bitwise-ior OFN_ALLOWMULTISELECT OFN_EXPLORER) 0) + (if directory OFN_NOCHANGEDIR 0)) + 0 + 0 + extension + 0 + #f + #f + #f + 0 + 0)] + [ofn (malloc 'raw (ctype-sizeof _OPENFILENAME))]) + (set-cpointer-tag! ofn OPENFILENAME-tag) + (memcpy ofn pre-ofn 1 _OPENFILENAME) + (if filename + (let* ([filename (path->string (simplify-path filename #f))] + [len (utf-16-length filename)]) + (memcpy (OPENFILENAME-lpstrFile ofn) + (cast filename _string/utf-16 _gcpointer) + (+ len 1) + _uint16)) + (ptr-set! (OPENFILENAME-lpstrFile ofn) _uint16 0)) + (let ([r (if (memq 'put style) + (GetSaveFileNameW ofn) + (GetOpenFileNameW ofn))]) + (begin0 + (and r + (if (memq 'multi style) + (let ([strs + (let ([p (OPENFILENAME-lpstrFile ofn)]) + (let loop ([pos 0]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + null] + [else (let ([end-pos + (let loop ([pos (+ pos 2)]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + pos] + [else (loop (+ pos 2))]))]) + (cons + (cast (ptr-add p pos) _pointer _string/utf-16) + (loop (+ end-pos 2))))])))]) + (if ((length strs) . < . 2) + #f + (map (lambda (p) (build-path (car strs) p)) + (cdr strs)))) + (cast (OPENFILENAME-lpstrFile ofn) _pointer _string/utf-16))) + (when directory + (free (OPENFILENAME-lpstrInitialDir ofn))) + (when message + (free (OPENFILENAME-lpstrTitle ofn))) + (free (OPENFILENAME-lpstrFilter ofn)) + (free (OPENFILENAME-lpstrFile ofn))))))) + +(define MAX_PATH 4096) + +(define (dialog-selector message directory + style parent) + (atomically + (let ([pre-bi (make-BROWSEINFO + (and parent + (send parent get-hwnd)) + #f + (malloc 'raw MAX_PATH _uint16) + message + (bitwise-ior BIF_NEWDIALOGSTYLE BIF_RETURNONLYFSDIRS) + #f + 0 + 0)] + [bi (malloc 'raw (ctype-sizeof _BROWSEINFO))]) + (set-cpointer-tag! bi BROWSEINFO-tag) + (memcpy bi pre-bi 1 _BROWSEINFO) + (let ([r (SHBrowseForFolderW bi)]) + (begin0 + (and r + (let ([ok (SHGetPathFromIDListW r (BROWSEINFO-pszDisplayName bi))]) + (and ok + (let ([mi (SHGetMalloc)]) + (IMalloc-Free mi r) + (IMalloc-Release mi)) + (string->path + (cast (BROWSEINFO-pszDisplayName bi) _pointer _string/utf-16))))) + (free (BROWSEINFO-pszDisplayName bi)) + (when message + (free (BROWSEINFO-lpszTitle bi)))))))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index e2a4e761..2efb432e 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -9,6 +9,7 @@ "menu-item.rkt" "frame.rkt" "dc.rkt" + "filedialog.rkt" racket/draw) (provide @@ -87,7 +88,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) -(define-unimplemented file-selector) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 4c3ccfd4..360e6719 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -3,6 +3,7 @@ (provide _wfun + _WORD _DWORD _UDWORD _ATOM @@ -14,6 +15,7 @@ _UINT_PTR _BYTE _LONG + _ULONG _SHORT _HRESULT _WCHAR @@ -35,6 +37,7 @@ _fnpointer _permanent-string/utf-16 + utf-16-length (struct-out POINT) _POINT _POINT-pointer (struct-out RECT) _RECT _RECT-pointer @@ -48,6 +51,7 @@ (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) +(define _WORD _int16) (define _DWORD _int32) (define _UDWORD _uint32) (define _ATOM _int) @@ -77,23 +81,28 @@ (define _fnpointer (_or-null _fpointer)) +(define (utf-16-length s) + (for/fold ([len 0]) ([c (in-string s)]) + (+ len + (if ((char->integer c) . > . #xFFFF) + 2 + 1)))) + (define _permanent-string/utf-16 (make-ctype _pointer (lambda (s) - (and s + (and s (let ([v (malloc _gcpointer)]) (ptr-set! v _string/utf-16 s) (let ([p (ptr-ref v _gcpointer)]) - (let ([len (let loop ([i 0]) - (if (zero? (ptr-ref p _uint16 i)) - (add1 i) - (loop (add1 i))))]) + (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] diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 25d4cb81..afda3e75 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -9,6 +9,7 @@ define-user32 define-kernel32 define-comctl32 + define-comdlg32 define-shell32 define-uxtheme define-mz @@ -45,6 +46,7 @@ (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define comdlg32-lib (ffi-lib "comdlg32.dll")) (define shell32-lib (ffi-lib "shell32.dll")) (define uxtheme-lib (ffi-lib "uxtheme.dll")) @@ -52,6 +54,7 @@ (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-comdlg32 comdlg32-lib) (define-ffi-definer define-shell32 shell32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) From 476e1c33b207110d05ba22fe8dc2fcfdd88802e3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 10:49:54 -0600 Subject: [PATCH 275/462] gtk: first cut at gl support original commit: 1a2ffacbbe811113db305d3cb269fdcb5e6ad024 --- collects/mred/private/kernel.rkt | 5 - collects/mred/private/wx/cocoa/platform.rkt | 1 - collects/mred/private/wx/gtk/canvas.rkt | 5 +- collects/mred/private/wx/gtk/dc.rkt | 8 ++ collects/mred/private/wx/gtk/gl-context.rkt | 139 ++++++++++++++++++-- collects/mred/private/wx/gtk/platform.rkt | 2 - collects/mred/private/wx/gtk/procs.rkt | 2 - collects/mred/private/wx/gtk/types.rkt | 2 + collects/mred/private/wx/gtk/utils.rkt | 4 + collects/mred/private/wx/platform.rkt | 1 - collects/mred/private/wx/win32/platform.rkt | 1 - 11 files changed, 148 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 61b01afc..5680a684 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -5,25 +5,20 @@ "wx/common/queue.rkt" "wx/common/clipboard.rkt" "wx/common/cursor.rkt" - "wx/common/gl-config.rkt" "wx/common/procs.rkt" "wx/common/handlers.rkt" racket/class racket/draw) -(define gl-context<%> (class->interface gl-context%)) - (define (key-symbol-to-integer k) (error 'key-symbol-to-integer "not yet implemented")) (provide (all-from-out "wx/platform.rkt") clipboard<%> - gl-context<%> (all-from-out "wx/common/event.rkt" "wx/common/timer.rkt" "wx/common/clipboard.rkt" "wx/common/cursor.rkt" - "wx/common/gl-config.rkt" "wx/common/procs.rkt") (all-from-out racket/draw) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 24805c7e..60e8507e 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -37,7 +37,6 @@ dialog% frame% gauge% - gl-context% group-panel% item% list-box% diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 8393b6de..0f84f0ad 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -186,7 +186,7 @@ x y w h style [ignored-name #f] - [gl-config #f]) + [gl-conf #f]) (inherit get-gtk set-size get-size get-client-size on-size get-top-win @@ -337,6 +337,9 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) + (define gl-config gl-conf) + (define/public (get-gl-config) gl-config) + (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 8265735c..e6421f3b 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -6,6 +6,7 @@ "window.rkt" "x11.rkt" "win32.rkt" + "gl-context.rkt" "../../lock.rkt" "../common/backing-dc.rkt" racket/draw/cairo @@ -82,6 +83,13 @@ (super-new) + (define gl #f) + (define/override (get-gl-context) + (or gl + (create-widget-gl-context + (send canvas get-client-gtk) + (send canvas get-gl-config)))) + (define/override (make-backing-bitmap w h) (cond [(and (eq? 'unix (system-type)) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index ba5d78e0..0ef54f59 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -1,11 +1,132 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/define + (prefix-in draw: racket/draw/gl-context) + racket/draw/gl-config + "types.rkt" + "utils.rkt") -(provide gl-context%) +(provide create-widget-gl-context) -(defclass gl-context% object% - (def/public-unimplemented call-as-current) - (def/public-unimplemented swap-buffers) - (def/public-unimplemented ok?) - (super-new)) +(define gdkglext-lib + (ffi-lib "libgdkglext-x11-1.0" '("0"))) +(define gtkglext-lib + (ffi-lib "libgtkglext-x11-1.0" '("0"))) + +(define-ffi-definer define-gdkglext gdkglext-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-gtkglext gtkglext-lib + #:default-make-fail make-not-available) + +(define _GdkGLContext (_cpointer/null 'GdkGLContext)) +(define _GdkGLDrawable (_cpointer 'GdkGLDrawable)) +(define _GdkGLConfig (_cpointer 'GdkGLConfig)) + +(define-gdkglext gdk_gl_init (_fun (_ptr i _int) + (_ptr i _pointer) + -> _void) + #:fail void) + +(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig))) +(define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig))) +(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) + +(define-gtkglext gtk_widget_set_gl_capability (_fun _GtkWidget + _GdkGLConfig + _GdkGLContext + _gboolean + _int + -> _gboolean) + #:fail (lambda args #f)) + +(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext)) +(define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable)) + +(define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable + _GdkGLContext + -> _gboolean)) +(define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void)) +(define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void)) + +(define GDK_GL_USE_GL 1) +(define GDK_GL_BUFFER_SIZE 2) +(define GDK_GL_LEVEL 3) +(define GDK_GL_RGBA 4) +(define GDK_GL_DOUBLEBUFFER 5) +(define GDK_GL_STEREO 6) +(define GDK_GL_AUX_BUFFERS 7) +(define GDK_GL_RED_SIZE 8) +(define GDK_GL_GREEN_SIZE 9) +(define GDK_GL_BLUE_SIZE 10) +(define GDK_GL_ALPHA_SIZE 11) +(define GDK_GL_DEPTH_SIZE 12) +(define GDK_GL_STENCIL_SIZE 13) +(define GDK_GL_ACCUM_RED_SIZE 14) +(define GDK_GL_ACCUM_GREEN_SIZE 15) +(define GDK_GL_ACCUM_BLUE_SIZE 16) +(define GDK_GL_ACCUM_ALPHA_SIZE 17) +(define GDK_GL_SAMPLE_BUFFERS 100000) +(define GDK_GL_SAMPLES 100001) +(define GDK_GL_ATTRIB_LIST_NONE 0) + +;; ---------------------------------------- + +(define (config->GdkGLConfig d conf) + (gdk_gl_config_new_for_screen d + (list GDK_GL_USE_GL 1 + GDK_GL_DOUBLEBUFFER (if (send conf get-double-buffered) 1 0) + GDK_GL_STEREO (if (send conf get-stereo) 1 0) + GDK_GL_DEPTH_SIZE (send conf get-depth-size) + GDK_GL_STENCIL_SIZE (send conf get-stencil-size) + GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size) + GDK_GL_SAMPLES (send conf get-multisample-size) + GDK_GL_ATTRIB_LIST_NONE 0))) + +;; ---------------------------------------- + +(define gl-context% + (class draw:gl-context% + (init-field [gl gl] + [drawable drawable]) + + (define/override (draw:do-call-as-current t) + (dynamic-wind + (lambda () + (gdk_gl_drawable_gl_begin gl drawable)) + t + (lambda () + (gdk_gl_drawable_gl_end drawable)))) + + (define/override (draw:do-swap-buffers) + (gdk_gl_drawable_swap_buffers drawable)) + + (super-new))) + +;; ---------------------------------------- + +(define inited? #f) +(define (init!) + (unless inited? + (set! inited? #t) + (gdk_gl_init 0 #f))) + +(define (create-widget-gl-context gtk config) + (init!) + (let ([config (config->GdkGLConfig (gtk_widget_get_screen gtk) + (or config + (new gl-config%)))]) + (and config + (gtk_widget_set_gl_capability gtk + config + #f + #t + #f) + (let ([gl (gtk_widget_get_gl_context gtk)]) + (and gl + (new gl-context% + [gl gl] + [drawable (gtk_widget_get_gl_window gtk)])))))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 19a1bec5..df851f8a 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -9,7 +9,6 @@ "dialog.rkt" "frame.rkt" "gauge.rkt" - "gl-context.rkt" "group-panel.rkt" "item.rkt" "list-box.rkt" @@ -37,7 +36,6 @@ dialog% frame% gauge% - gl-context% group-panel% item% list-box% diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 7c5dcfd9..95eaacfa 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -81,8 +81,6 @@ (define-unimplemented write-resource) (define-unimplemented get-resource) -(define _GdkScreen (_cpointer 'GdkScreen)) -(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) (define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) (define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 2f51e5e2..7ba1ab7b 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -5,6 +5,7 @@ (provide _GdkWindow _GtkWidget _GtkWindow _GdkDisplay + _GdkScreen _gpointer _GType @@ -36,6 +37,7 @@ (define _GtkWindow _GtkWidget) (define _GdkDisplay (_cpointer 'GdkDisplay)) +(define _GdkScreen (_cpointer 'GdkScreen)) (define _gpointer _GtkWidget) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 6a1007c8..7b879119 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -41,6 +41,8 @@ define-signal-handler + gdk_screen_get_default + ;; for declaring derived structures: _GtkObject) @@ -203,3 +205,5 @@ (cons ((ctype-c->scheme elem) (g-slist-data gl)) (L (g-slist-next gl))))) (g_slist_free gl))))) + +(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index a3b1555a..10e6e4e0 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -21,7 +21,6 @@ dialog% frame% gauge% - gl-context% group-panel% item% list-box% diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 96878af4..a1903094 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -37,7 +37,6 @@ dialog% frame% gauge% - gl-context% group-panel% item% list-box% From 9875174de88961fe80a6ade26c1405aed3db56ab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 12:01:45 -0600 Subject: [PATCH 276/462] gtk: more gl original commit: b2981f05b20b1de40fd21e11e8d088a717d74e40 --- collects/mred/private/wx/gtk/canvas.rkt | 9 +-- collects/mred/private/wx/gtk/dc.rkt | 6 +- collects/mred/private/wx/gtk/gl-context.rkt | 62 ++++++++++++--------- 3 files changed, 43 insertions(+), 34 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 0f84f0ad..5d82ff9d 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -17,6 +17,7 @@ "client-window.rkt" "widget.rkt" "dc.rkt" + "gl-context.rkt" "combo.rkt" "pixbuf.rkt" "gcwin.rkt") @@ -186,7 +187,7 @@ x y w h style [ignored-name #f] - [gl-conf #f]) + [gl-config #f]) (inherit get-gtk set-size get-size get-client-size on-size get-top-win @@ -286,6 +287,9 @@ (define dc (new dc% [canvas this])) + (when (memq 'gl style) + (prepare-widget-gl-context client-gtk gl-config)) + (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) @@ -337,9 +341,6 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) - (define gl-config gl-conf) - (define/public (get-gl-config) gl-config) - (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index e6421f3b..a3c410c9 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -86,9 +86,9 @@ (define gl #f) (define/override (get-gl-context) (or gl - (create-widget-gl-context - (send canvas get-client-gtk) - (send canvas get-gl-config)))) + (let ([v (create-widget-gl-context (send canvas get-client-gtk))]) + (when v (set! gl v)) + v))) (define/override (make-backing-bitmap w h) (cond diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index 0ef54f59..e310c687 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -7,7 +7,8 @@ "types.rkt" "utils.rkt") -(provide create-widget-gl-context) +(provide prepare-widget-gl-context + create-widget-gl-context) (define gdkglext-lib (ffi-lib "libgdkglext-x11-1.0" '("0"))) @@ -30,6 +31,7 @@ (define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig))) (define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig))) + (define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) (define-gtkglext gtk_widget_set_gl_capability (_fun _GtkWidget @@ -73,18 +75,20 @@ ;; ---------------------------------------- (define (config->GdkGLConfig d conf) - (gdk_gl_config_new_for_screen d - (list GDK_GL_USE_GL 1 - GDK_GL_DOUBLEBUFFER (if (send conf get-double-buffered) 1 0) - GDK_GL_STEREO (if (send conf get-stereo) 1 0) - GDK_GL_DEPTH_SIZE (send conf get-depth-size) - GDK_GL_STENCIL_SIZE (send conf get-stencil-size) - GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size) - GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size) - GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size) - GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size) - GDK_GL_SAMPLES (send conf get-multisample-size) - GDK_GL_ATTRIB_LIST_NONE 0))) + (gdk_gl_config_new (append + (list GDK_GL_RGBA) + (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null) + (if (send conf get-stereo) (list GDK_GL_STEREO) null) + (list + GDK_GL_DEPTH_SIZE (send conf get-depth-size) + GDK_GL_STENCIL_SIZE (send conf get-stencil-size) + GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size)) + #; + (list GDK_GL_SAMPLES (send conf get-multisample-size)) + (list GDK_GL_ATTRIB_LIST_NONE)))) ;; ---------------------------------------- @@ -96,7 +100,7 @@ (define/override (draw:do-call-as-current t) (dynamic-wind (lambda () - (gdk_gl_drawable_gl_begin gl drawable)) + (gdk_gl_drawable_gl_begin drawable gl)) t (lambda () (gdk_gl_drawable_gl_end drawable)))) @@ -114,19 +118,23 @@ (set! inited? #t) (gdk_gl_init 0 #f))) -(define (create-widget-gl-context gtk config) +(define (prepare-widget-gl-context gtk config) (init!) - (let ([config (config->GdkGLConfig (gtk_widget_get_screen gtk) + (let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk) (or config (new gl-config%)))]) - (and config - (gtk_widget_set_gl_capability gtk - config - #f - #t - #f) - (let ([gl (gtk_widget_get_gl_context gtk)]) - (and gl - (new gl-context% - [gl gl] - [drawable (gtk_widget_get_gl_window gtk)])))))) + (when config + (gtk_widget_set_gl_capability gtk + config + #f + #t + 0)))) + +(define (create-widget-gl-context gtk) + (init!) + (let ([gl (gtk_widget_get_gl_context gtk)]) + (and gl + (new gl-context% + [gl gl] + [drawable (gtk_widget_get_gl_window gtk)])))) + From b6651db0ba156b27dc62c793ed0c98a130a637ff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 12:35:58 -0600 Subject: [PATCH 277/462] cocoa: opengl canvases original commit: 1bddb120f9f460e089d926f3f57f6618b733e6a5 --- collects/mred/private/wx/cocoa/canvas.rkt | 58 +++++++++++++++++-- collects/mred/private/wx/cocoa/dc.rkt | 20 +++++++ collects/mred/private/wx/cocoa/platform.rkt | 1 - collects/scribblings/gui/canvas-class.scrbl | 9 ++- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 3 + 5 files changed, 83 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index b691eb25..34b8853b 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -3,6 +3,7 @@ ffi/unsafe racket/class racket/draw + racket/draw/gl-context racket/draw/color "pool.rkt" "utils.rkt" @@ -28,7 +29,8 @@ ;; ---------------------------------------- (import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow - NSImageView NSTextFieldCell) + NSImageView NSTextFieldCell + NSOpenGLView NSOpenGLPixelFormat) (import-protocol NSComboBoxDelegate) @@ -55,7 +57,7 @@ (make-NSSize 32000 32000)))) (tellv ctx restoreGraphicsState))))))) -(define-objc-class MyView NSView +(define-objc-mixin (MyViewMixin Superclass) #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) [wxb] (-a _void (drawRect: [_NSRect r]) @@ -80,6 +82,14 @@ (let ([wx (->wx wxb)]) (when wx (send wx do-scroll 'vertical scroller)))))) +(define-objc-class MyView NSView + #:mixins (MyViewMixin) + [wxb]) + +(define-objc-class MyGLView NSOpenGLView + #:mixins (MyViewMixin) + [wxb]) + (define-objc-class FrameView NSView [] (-a _void (drawRect: [_NSRect r]) @@ -172,6 +182,39 @@ (let ([wx (->wx wxb)]) (when wx (queue-window-event wx (lambda () (send wx fix-dc)))))))) + +(define NSOpenGLPFADoubleBuffer 5) +(define NSOpenGLPFAStereo 6) +(define NSOpenGLPFAColorSize 8) +(define NSOpenGLPFAAlphaSize 11) +(define NSOpenGLPFADepthSize 12) +(define NSOpenGLPFAStencilSize 13) +(define NSOpenGLPFAAccumSize 14) +(define NSOpenGLPFAOffScreen 53) +(define NSOpenGLPFASampleBuffers 55) +(define NSOpenGLPFASamples 56) +(define NSOpenGLPFAMultisample 59) + +(define (gl-config->pixel-format conf) + (let ([conf (or conf (new gl-config%))]) + (tell (tell NSOpenGLPixelFormat alloc) + initWithAttributes: #:type (_list i _int) + (append + (if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null) + (if (send conf get-stereo) (list NSOpenGLPFAStereo) null) + (list + NSOpenGLPFADepthSize (send conf get-depth-size) + NSOpenGLPFAStencilSize (send conf get-stencil-size) + NSOpenGLPFAAccumSize (send conf get-accum-size)) + #; + (let ([ms (send conf get-multisample-size)]) + (if (zero? ms) + null + (list NSOpenGLPFAMultisample + NSOpenGLPFASampleBuffers + NSOpenGLPFASamples ms))) + (list 0))))) + (define-struct scroller (cocoa [range #:mutable] [page #:mutable])) (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) @@ -259,6 +302,9 @@ (define/override (get-cocoa-content) content-cocoa) + (define is-gl? (and (not is-combo?) (memq 'gl style))) + (define/public (can-gl?) is-gl?) + (super-new [parent parent] [cocoa @@ -283,8 +329,12 @@ (make-NSSize (max 0 (- w (* 2 x-margin))) (max 0 (- h (* 2 y-margin)))))]) (as-objc-allocation - (tell (tell (if is-combo? MyComboBox MyView) alloc) - initWithFrame: #:type _NSRect r)))) + (if (or is-combo? (not (memq 'gl style))) + (tell (tell (if is-combo? MyComboBox MyView) alloc) + initWithFrame: #:type _NSRect r) + (tell (tell MyGLView alloc) + initWithFrame: #:type _NSRect r + pixelFormat: (gl-config->pixel-format gl-config)))))) (tell #:type _void cocoa addSubview: content-cocoa) (set-ivar! content-cocoa wxb (->wxb this)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 2ecb3f47..72e77eaa 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -5,6 +5,7 @@ racket/draw/cairo racket/draw/bitmap racket/draw/local + racket/draw/gl-context "types.rkt" "utils.rkt" "window.rkt" @@ -17,6 +18,8 @@ quartz-bitmap% do-backing-flush) +(import-class NSOpenGLContext) + (define quartz-bitmap% (class bitmap% (init w h) @@ -46,6 +49,23 @@ (super-new) + (define gl #f) + (define/override (get-gl-context) + (and (send canvas can-gl?) + (let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)]) + (or gl + (let ([g (new (class gl-context% + (define/override (do-call-as-current t) + (dynamic-wind + (lambda () (tellv gl-ctx makeCurrentContext)) + t + (lambda () (tellv NSOpenGLContext clearCurrentContext)))) + (define/override (do-swap-buffers) + (tellv gl-ctx flushBuffer)) + (super-new)))]) + (set! gl g) + g))))) + ;; Use a quartz bitmap so that text looks good: (define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h)) (define/override (can-combine-text? sz) #t) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 60e8507e..b51b20f6 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -9,7 +9,6 @@ "dialog.rkt" "frame.rkt" "gauge.rkt" - "gl-context.rkt" "group-panel.rkt" "item.rkt" "list-box.rkt" diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 992c8e9c..3159774a 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -45,11 +45,14 @@ The @scheme[style] argument indicates one or more of the following styles: @item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's bottom right when only one scrollbar is visible} - @item{@scheme['gl] --- @italic{obsolete} (every canvas is an OpenGL context where supported)} + @item{@scheme['gl] --- enables OpenGL drawing to the canvas, and usually + combined with @racket['no-autoclear]; call the @method[dc<%> + get-gl-context] method of the canvas's drawing context as + produced by @method[canvas<%> get-dc]} @item{@scheme['no-autoclear] --- prevents automatic erasing of the - canvas before calls to -@method[canvas% on-paint]} + canvas before calls to @method[canvas% on-paint]} + @item{@scheme['transparent] --- the canvas is automatically ``erased'' before an update using it's parent window's background; the result is undefined if this flag is combined with @scheme['no-autoclear]} diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index b56ac8d6..6c50f8a4 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -84,6 +84,9 @@ Changes to the drawing toolbox: the foreground in the color specified by `get-highlight-text-color', if any. + * OpenGL drawing in a canvas requires supplying 'gl as a style when + creating the `canvas%' instance. + Changes to the GUI toolbox: [Nothing to report, yet.] From 08544f18b23c6ca0e8290a4fd72ecb50c1a0085c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 14:43:54 -0600 Subject: [PATCH 278/462] win32: canvas gl, almost original commit: b9e6ffe18c651d58bd32c8fc50f171edd5acf878 --- collects/mred/private/wx/cocoa/canvas.rkt | 6 +- .../mred/private/wx/common/backing-dc.rkt | 12 +- .../mred/private/wx/common/canvas-mixin.rkt | 4 +- collects/mred/private/wx/gtk/canvas.rkt | 1 + collects/mred/private/wx/win32/canvas.rkt | 26 +++- collects/mred/private/wx/win32/dc.rkt | 11 ++ collects/mred/private/wx/win32/gl-context.rkt | 146 ++++++++++++++++-- collects/mred/private/wx/win32/window.rkt | 3 +- 8 files changed, 184 insertions(+), 25 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 34b8853b..3c9f42d6 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -579,14 +579,16 @@ #t) (define/public (on-combo-select i) (void)) + (define clear-bg? (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)))) (define bg-col (make-object color% "white")) (define/public (get-canvas-background) (if (memq 'transparent canvas-style) #f bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col)) (define/public (get-canvas-background-for-clearing) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) + (and clear-bg? bg-col)) (define/public (reject-partial-update r) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index c77f6173..7b848a55 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -38,8 +38,7 @@ (inherit call-with-cr-lock internal-get-bitmap internal-set-bitmap - reset-cr - erase) + reset-cr) (super-new) @@ -57,6 +56,7 @@ (define retained-cr #f) (define retained-counter 0) (define needs-flush? #f) + (define nada? #t) ;; called with a procedure that is applied to a bitmap; ;; returns #f if there's nothing to flush @@ -64,7 +64,8 @@ (cond [(not retained-cr) #f] [(positive? retained-counter) - (proc (internal-get-bitmap)) + (unless nada? + (proc (internal-get-bitmap))) #t] [else (reset-backing-retained proc) @@ -113,9 +114,14 @@ cr)))) (define/override (release-cr cr) + (set! nada? #f) (when (zero? flush-suspends) (queue-backing-flush))) + (define/override (erase) + (super erase) + (set! nada? #t)) + (define flush-suspends 0) (define req #f) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index cd1a3280..2e428a41 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -120,7 +120,7 @@ on-paint queue-backing-flush get-dc - get-canvas-background) + get-canvas-background-for-backing) ;; Avoid multiple queued paints, and also allow cancel ;; of queued paint: @@ -146,7 +146,7 @@ (send dc suspend-flush) (send dc ensure-ready) (send dc erase) ; start with a clean slate - (let ([bg (get-canvas-background)]) + (let ([bg (get-canvas-background-for-backing)]) (when bg (let ([old-bg (send dc get-background)]) (send dc set-background bg) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 5d82ff9d..5a154433 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -497,6 +497,7 @@ #f bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col)) (define/public (get-canvas-background-for-clearing) ;; called in event-dispatch mode (if clear-bg? diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 24722e4c..41a3ab78 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -75,7 +75,7 @@ x y w h style [ignored-name #f] - [gl-config #f]) + [gl-conf #f]) (inherit get-hwnd get-client-size @@ -156,13 +156,16 @@ (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) (unless (positive? paint-suspended) - (let* ([hbrush (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref))]) - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush)) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) (unless (do-backing-flush this dc hdc) (queue-paint)))) (EndPaint hdc ps)) @@ -200,6 +203,9 @@ (define/public (get-dc) dc) + (define gl-config gl-conf) + (define/public (get-gl-config) gl-config) + (define/override (on-resized) (reset-dc)) @@ -262,12 +268,16 @@ (unless (zero? paint-suspended) (set! paint-suspended (sub1 paint-suspended))))) + (define no-autoclear? (memq 'no-autoclear style)) (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) (define bg-colorref #xFFFFFF) (define/public (get-canvas-background) (if transparent? #f bg-col)) + (define/public (get-canvas-background-for-backing) (and (not transparent?) + (not no-autoclear?) + bg-col)) (define/public (set-canvas-background col) (atomically (set! bg-col col) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index efdd082b..9c14dc1f 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -3,6 +3,7 @@ racket/class "utils.rkt" "types.rkt" + "gl-context.rkt" "../../lock.rkt" "../common/backing-dc.rkt" "../common/delay.rkt" @@ -59,6 +60,16 @@ (super-new) + (define gl #f) + (define/override (get-gl-context) + (or gl + (let ([v (create-gl-context (GetDC (send canvas get-client-hwnd)) + (send canvas get-gl-config) + #f)]) + (when v (set! gl v)) + v))) + + (define/override (make-backing-bitmap w h) (if (send canvas get-canvas-background) (make-object win32-bitmap% w h (send canvas get-hwnd)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt index ba5d78e0..6aa27b53 100644 --- a/collects/mred/private/wx/win32/gl-context.rkt +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -1,11 +1,139 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + racket/draw/gl-config + (prefix-in draw: racket/draw/gl-context) + "types.rkt" + "utils.rkt") -(provide gl-context%) +(provide create-gl-context) -(defclass gl-context% object% - (def/public-unimplemented call-as-current) - (def/public-unimplemented swap-buffers) - (def/public-unimplemented ok?) - (super-new)) +(define opengl32-lib (ffi-lib "opengl32.dll")) + +(define-ffi-definer define-opengl32 opengl32-lib) + +(define _HGLRC (_cpointer/null 'HGLRC)) + +(define-cstruct _PIXELFORMATDESCRIPTOR + ([nSize _WORD] + [nVersion _WORD] + [dwFlags _DWORD] + [iPixelType _BYTE] + [cColorBits _BYTE] + [cRedBits _BYTE] + [cRedShift _BYTE] + [cGreenBits _BYTE] + [cGreenShift _BYTE] + [cBlueBits _BYTE] + [cBlueShift _BYTE] + [cAlphaBits _BYTE] + [cAlphaShift _BYTE] + [cAccumBits _BYTE] + [cAccumRedBits _BYTE] + [cAccumGreenBits _BYTE] + [cAccumBlueBits _BYTE] + [cAccumAlphaBits _BYTE] + [cDepthBits _BYTE] + [cStencilBits _BYTE] + [cAuxBuffers _BYTE] + [iLayerType _BYTE] + [bReserved _BYTE] + [dwLayerMask _DWORD] + [dwVisibleMask _DWORD] + [dwDamageMask _DWORD])) + +(define-gdi32 ChoosePixelFormat (_wfun _HDC _PIXELFORMATDESCRIPTOR-pointer -> _int)) +(define-gdi32 SetPixelFormat (_wfun _HDC _int _PIXELFORMATDESCRIPTOR-pointer -> _BOOL)) +(define-gdi32 DescribePixelFormat (_wfun _HDC _int _UINT _PIXELFORMATDESCRIPTOR-pointer -> (r : _int) + -> (if (zero? r) + (failed 'DescribePixelFormat) + r))) +(define-gdi32 SwapBuffers (_wfun _HDC -> _BOOL)) + +(define-opengl32 wglDeleteContext (_wfun _HGLRC -> (r : _BOOL) + -> (unless r (failed 'wglDeleteContext))) + #:wrap (deallocator)) +(define-opengl32 wglCreateContext (_wfun _HDC -> _HGLRC) + #:wrap (allocator wglDeleteContext)) + +(define-opengl32 wglMakeCurrent (_wfun _HDC _HGLRC -> _BOOL)) + +;; ---------------------------------------- + +(define gl-context% + (class draw:gl-context% + (init-field [hglrc hglrc] + [hdc hdc]) + + (define/override (draw:do-call-as-current t) + (dynamic-wind + (lambda () + (wglMakeCurrent hdc hglrc)) + t + (lambda () + (wglMakeCurrent #f #f)))) + + (define/override (draw:do-swap-buffers) + (SwapBuffers hdc)) + + (super-new))) + +;; ---------------------------------------- + +(define PFD_DOUBLEBUFFER #x00000001) +(define PFD_STEREO #x00000002) +(define PFD_DRAW_TO_WINDOW #x00000004) +(define PFD_DRAW_TO_BITMAP #x00000008) +(define PFD_SUPPORT_GDI #x00000010) +(define PFD_SUPPORT_OPENGL #x00000020) +(define PFD_NEED_PALETTE #x00000080) +(define PFD_NEED_SYSTEM_PALETTE #x00000100) +(define PFD_GENERIC_ACCELERATED #x00001000) +(define PFD_TYPE_RGBA 0) +(define PFD_MAIN_PLANE 0) + +(define (create-gl-context hdc config offscreen?) + (let* ([config (or config (new gl-config%))] + [accum (send config get-accum-size)] + [pfd + (make-PIXELFORMATDESCRIPTOR + (ctype-sizeof _PIXELFORMATDESCRIPTOR) + 1 ; version + (bitwise-ior + PFD_SUPPORT_OPENGL + (if (send config get-stereo) PFD_STEREO 0) + (if (and (not offscreen?) + (send config get-double-buffered)) + PFD_DOUBLEBUFFER + 0) + (if offscreen? + (bitwise-ior PFD_DRAW_TO_BITMAP + PFD_SUPPORT_GDI) + (bitwise-ior PFD_DRAW_TO_WINDOW))) + PFD_TYPE_RGBA ; color type + (if offscreen? 32 24) ; prefered color depth + 0 0 0 0 0 0 ; color bits (ignored) + 0 ; no alpha buffer + 0 ; alpha bits (ignored) + (* 4 accum) ; no accumulation buffer + accum accum accum accum ; accum bits + (if offscreen? 32 (send config get-depth-size)) ; depth buffer + (send config get-stencil-size) ; stencil buffer + 0 ; no auxiliary buffers + PFD_MAIN_PLANE ; main layer + 0 ; reserved + 0 0 0 ; no layer, visible, damage masks + )] + [pixelFormat (ChoosePixelFormat hdc pfd)]) + (and (not (zero? pixelFormat)) + (SetPixelFormat hdc pixelFormat pfd) + (begin + (DescribePixelFormat hdc pixelFormat (ctype-sizeof _PIXELFORMATDESCRIPTOR) pfd) + (when (not (zero? (bitwise-and (PIXELFORMATDESCRIPTOR-dwFlags pfd) + PFD_NEED_PALETTE))) + (log-error "don't know how to create a GL palette, yet")) + (let ([hglrc (wglCreateContext hdc)]) + (and hglrc + (new gl-context% [hglrc hglrc] [hdc hdc]))))))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 24a00f02..72a191dd 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -537,7 +537,8 @@ (define/public (send-leaves mk) (set! mouse-in? #f) (let ([e (mk 'leave)]) - (if (eq? (current-eventspace) (get-eventspace)) + (if (eq? (current-thread) + (eventspace-handler-thread (get-eventspace))) (handle-mouse-event (get-client-hwnd) 0 0 e) (queue-window-event this (lambda () (dispatch-on-event/sync e)))))) From 936d7347c797f5c03daaf20ae4313b35d471be32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 17:38:49 -0600 Subject: [PATCH 279/462] win32: fix gl canvas repaint original commit: 3d9f52a4d12bb869aecbf7e2c9dbc819344925a5 --- collects/mred/private/wx/win32/canvas.rkt | 32 +++++++++++++---------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 41a3ab78..a5aabf12 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -89,6 +89,7 @@ (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) + (define for-gl? (memq 'gl style)) (define panel-hwnd (and (memq 'combo style) @@ -155,19 +156,21 @@ [(= msg WM_PAINT) (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) - (unless (positive? paint-suspended) - (let* ([hbrush (if no-autoclear? - #f - (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref)))]) - (when hbrush - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush))) - (unless (do-backing-flush this dc hdc) - (queue-paint)))) + (if for-gl? + (queue-paint) + (unless (positive? paint-suspended) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-backing-flush this dc hdc) + (queue-paint))))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -254,7 +257,8 @@ (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) - (InvalidateRect canvas-hwnd #f #f)) + (unless for-gl? + (InvalidateRect canvas-hwnd #f #f))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) From 8b11d03f69a34bb6cb1140b0b956fcb86144da0b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 17:45:03 -0600 Subject: [PATCH 280/462] gtk: fix gl canvas painting original commit: bc509c86cd1c306bc7ad1520bc634081f862248f --- collects/mred/private/wx/gtk/canvas.rkt | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 5a154433..c9d80e41 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -287,7 +287,8 @@ (define dc (new dc% [canvas this])) - (when (memq 'gl style) + (define for-gl? (memq 'gl style)) + (when for-gl? (prepare-widget-gl-context client-gtk gl-config)) (gtk_widget_realize gtk) @@ -355,12 +356,14 @@ (queue-window-refresh-event this thunk)) (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (if is-combo? - (get-subwindow client-gtk) - (widget-window client-gtk))) - (begin - (queue-paint) - #f))) + (if for-gl? + (queue-paint) + (or (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (widget-window client-gtk))) + (begin + (queue-paint) + #f)))) (define/public (on-paint) (void)) @@ -376,7 +379,8 @@ (define/public (queue-backing-flush) ;; called atomically (not expecting exceptions) - (gtk_widget_queue_draw client-gtk)) + (unless for-gl? + (gtk_widget_queue_draw client-gtk))) (define/override (reset-child-dcs) (when (dc . is-a? . dc%) From c0429ba8db4e30cd42652f7024e2f41237fd3d32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 20:49:27 -0600 Subject: [PATCH 281/462] `make-gl-bitmap' for cocoa and maybe gtk original commit: 0a47a81aba1c9e2f88984357b0d665700a360ee1 --- collects/mred/mred-sig.rkt | 1 + collects/mred/mred.rkt | 3 +- collects/mred/private/wx/cocoa/canvas.rkt | 3 +- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 7 +++ collects/mred/private/wx/gtk/dc.rkt | 8 +++ collects/mred/private/wx/gtk/gl-context.rkt | 50 +++++++++++++++++-- collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 9 ++++ collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 6 +++ collects/scribblings/gui/canvas-class.scrbl | 9 ++-- collects/scribblings/gui/miscwin-funcs.scrbl | 14 ++++++ doc/release-notes/racket/Draw_and_GUI_5_5.txt | 11 ++-- 15 files changed, 109 insertions(+), 16 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 72d97f8b..53b52e26 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -123,6 +123,7 @@ make-eventspace make-gui-empty-namespace make-gui-namespace make-screen-bitmap +make-gl-bitmap map-command-as-meta-key menu% menu-bar% diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index d4113ebf..59f6dcbf 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -191,7 +191,8 @@ the-brush-list the-style-list the-editor-wordbreak-map - make-screen-bitmap) + make-screen-bitmap + make-gl-bitmap) (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 3c9f42d6..dabf6444 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -206,12 +206,11 @@ NSOpenGLPFADepthSize (send conf get-depth-size) NSOpenGLPFAStencilSize (send conf get-stencil-size) NSOpenGLPFAAccumSize (send conf get-accum-size)) - #; (let ([ms (send conf get-multisample-size)]) (if (zero? ms) null (list NSOpenGLPFAMultisample - NSOpenGLPFASampleBuffers + NSOpenGLPFASampleBuffers 1 NSOpenGLPFASamples ms))) (list 0))))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index b51b20f6..5dcb42bf 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -85,4 +85,5 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 9734d1d4..cf31e6e0 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -12,6 +12,7 @@ "filedialog.rkt" "dc.rkt" "menu-bar.rkt" + "agl.rkt" "../../lock.rkt" "../common/handlers.rkt") @@ -52,6 +53,7 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break) (import-class NSScreen NSCursor) @@ -113,6 +115,11 @@ [exact-positive-integer? h]) (make-object quartz-bitmap% w h)) +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (create-gl-bitmap w h c)) + ;; ------------------------------------------------------------ ;; Text & highlight color diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a3c410c9..331f7f3a 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -37,6 +37,14 @@ w h)) + ;; `get-gdk-pixmap' and `install-gl-context' are + ;; localized in "gl-context.rkt" + (define/public (get-gdk-pixmap) pixmap) + (define/public (install-gl-context new-gl) (set! gl new-gl)) + + (define gl #f) + (define/override (get-bitmap-gl-context) gl) + (define/override (ok?) #t) (define/override (is-color?) #t) (define/override (has-alpha-channel?) #f) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index e310c687..0db687bb 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -2,13 +2,18 @@ (require racket/class ffi/unsafe ffi/unsafe/define + ffi/unsafe/alloc (prefix-in draw: racket/draw/gl-context) racket/draw/gl-config "types.rkt" "utils.rkt") (provide prepare-widget-gl-context - create-widget-gl-context) + create-widget-gl-context + + create-and-install-gl-context + get-gdk-pixmap + install-gl-context) (define gdkglext-lib (ffi-lib "libgdkglext-x11-1.0" '("0"))) @@ -23,6 +28,8 @@ (define _GdkGLContext (_cpointer/null 'GdkGLContext)) (define _GdkGLDrawable (_cpointer 'GdkGLDrawable)) (define _GdkGLConfig (_cpointer 'GdkGLConfig)) +(define _GdkGLPixmap _GdkGLDrawable) +(define _GdkPixmap _pointer) (define-gdkglext gdk_gl_init (_fun (_ptr i _int) (_ptr i _pointer) @@ -45,12 +52,26 @@ (define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext)) (define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable)) +(define-gdkglext gdk_gl_context_destroy (_fun _GdkGLContext -> _void) + #:wrap (deallocator)) + +(define-gdkglext gdk_gl_context_new (_fun _GdkGLDrawable _GdkGLContext _gboolean _int + -> _GdkGLContext) + #:wrap (allocator gdk_gl_context_destroy)) + (define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable _GdkGLContext -> _gboolean)) (define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void)) (define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void)) +(define-gdkglext gdk_gl_pixmap_destroy (_fun _GdkGLPixmap -> _void) + #:wrap (deallocator)) +(define-gdkglext gdk_gl_pixmap_new (_fun _GdkGLConfig _GdkPixmap _pointer -> _GdkGLPixmap) + #:wrap (allocator gdk_gl_pixmap_destroy)) + +(define GDK_GL_RGBA_TYPE 0) + (define GDK_GL_USE_GL 1) (define GDK_GL_BUFFER_SIZE 2) (define GDK_GL_LEVEL 3) @@ -74,10 +95,12 @@ ;; ---------------------------------------- -(define (config->GdkGLConfig d conf) +(define (config->GdkGLConfig d conf can-double?) (gdk_gl_config_new (append (list GDK_GL_RGBA) - (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null) + (if can-double? + (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null) + null) (if (send conf get-stereo) (list GDK_GL_STEREO) null) (list GDK_GL_DEPTH_SIZE (send conf get-depth-size) @@ -122,7 +145,8 @@ (init!) (let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk) (or config - (new gl-config%)))]) + (new gl-config%)) + #t)]) (when config (gtk_widget_set_gl_capability gtk config @@ -138,3 +162,21 @@ [gl gl] [drawable (gtk_widget_get_gl_window gtk)])))) + +(define-local-member-name + get-gdk-pixmap + install-gl-context) + +(define (create-and-install-gl-context bm config) + (init!) + (let ([config (config->GdkGLConfig #f config #f)]) + (when config + (let ([gdkpx (send bm get-gdk-pixmap)]) + (let ([glpx (gdk_gl_pixmap_new config gdkpx #f)]) + (and glpx + (let ([gl (gdk_gl_context_new glpx #f #t GDK_GL_RGBA_TYPE)]) + (and gl + (new gl-context% + [gl gl] + [drawable glpx]))))))))) + diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index df851f8a..d71e484a 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -85,4 +85,5 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 95eaacfa..6b77bd50 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -11,6 +11,7 @@ "widget.rkt" "window.rkt" "dc.rkt" + "gl-context.rkt" "../common/handlers.rkt") (provide @@ -50,6 +51,7 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break) (define-unimplemented special-control-key) @@ -118,4 +120,11 @@ (make-object x11-bitmap% w h #f) (make-object bitmap% w h #f #t))) +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (let ([bm (make-object x11-bitmap% w h #f)]) + (create-and-install-gl-context bm c) + bm)) + (define (check-for-break) #f) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 10e6e4e0..6375991f 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -70,5 +70,6 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index a1903094..2a71e0e2 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -86,4 +86,5 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 2efb432e..9659eb6f 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -48,6 +48,7 @@ get-highlight-background-color get-highlight-text-color make-screen-bitmap + make-gl-bitmap check-for-break) (define-unimplemented special-control-key) @@ -102,4 +103,9 @@ [exact-positive-integer? h]) (make-object win32-bitmap% w h #f)) +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (make-object win32-bitmap% w h #f)) + (define (check-for-break) #f) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 3159774a..161333d8 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -45,10 +45,11 @@ The @scheme[style] argument indicates one or more of the following styles: @item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's bottom right when only one scrollbar is visible} - @item{@scheme['gl] --- enables OpenGL drawing to the canvas, and usually - combined with @racket['no-autoclear]; call the @method[dc<%> - get-gl-context] method of the canvas's drawing context as - produced by @method[canvas<%> get-dc]} + @item{@scheme['gl] --- creates a canvas for OpenGL drawing instead of + normal @racket[dc<%>] drawing; call the @method[dc<%> + get-gl-context] method on the result of @method[canvas<%> + get-dc]; this style is usually combined with + @racket['no-autoclear]} @item{@scheme['no-autoclear] --- prevents automatic erasing of the canvas before calls to @method[canvas% on-paint]} diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index bcd3e71d..7771bf77 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -276,6 +276,20 @@ Strips shortcut ampersands from @racket[label], removes parenthesized } +@defproc[(make-gl-bitmap [width exact-positive-integer?] + [height exact-positive-integer?] + [config (is-a?/c gl-config%)]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that supports both normal @racket[dc<%>] drawing an +OpenGL drawing through a context returned by @xmethod[dc<%> get-gl-context]. + +For @racket[dc<%>] drawing, an OpenGL-supporting bitmap draws like a +bitmap frmo @racket[make-screen-bitmap] on some platforms, while it +draws like a bitmap instantiated directly from @racket[bitmap%] on +other platforms.} + + @defproc[(make-gui-empty-namespace) namespace?]{ Like @racket[make-base-empty-namespace], but with diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index 6c50f8a4..6be461a7 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -1,4 +1,4 @@ -Changes to the drawing toolbox: +Changes: * The drawing portion of the old GUI toolbox is now available as a separate layer: `racket/draw'. This layer can be used from plain @@ -15,7 +15,7 @@ Changes to the drawing toolbox: Drawing to a canvas always draws into a bitmap that is kept offscreen and periodically flushed onto the screen. The new - `suspend-flush' and `resume-fluah' methods of `canvas%' provide + `suspend-flush' and `resume-flush' methods of `canvas%' provide some control over the timing of the flushes, which in many cases avoids the need for (additional) double buffering of canvas content. @@ -85,8 +85,9 @@ Changes to the drawing toolbox: `get-highlight-text-color', if any. * OpenGL drawing in a canvas requires supplying 'gl as a style when - creating the `canvas%' instance. + creating the `canvas%' instance. OpenGL and normal dc<%> drawing no + longer mix reliably in a canvas. -Changes to the GUI toolbox: + OpenG drawing to a bitmap requires a bitmap created with + `make-gl-bitmap'. - [Nothing to report, yet.] From 13831d20c0714f5230fd592ad7359ebaf246414e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 21:14:15 -0600 Subject: [PATCH 282/462] gtk: fix gl bitmap original commit: 0433cd0337bc6354ab18ae54368fe8f3deeccdde --- collects/mred/private/wx/gtk/gl-context.rkt | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index 0db687bb..f4c213eb 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -65,10 +65,8 @@ (define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void)) (define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void)) -(define-gdkglext gdk_gl_pixmap_destroy (_fun _GdkGLPixmap -> _void) - #:wrap (deallocator)) -(define-gdkglext gdk_gl_pixmap_new (_fun _GdkGLConfig _GdkPixmap _pointer -> _GdkGLPixmap) - #:wrap (allocator gdk_gl_pixmap_destroy)) +(define-gdkglext gdk_pixmap_set_gl_capability (_fun _GdkPixmap _GdkGLConfig _pointer + -> _GdkGLPixmap)) (define GDK_GL_RGBA_TYPE 0) @@ -172,11 +170,14 @@ (let ([config (config->GdkGLConfig #f config #f)]) (when config (let ([gdkpx (send bm get-gdk-pixmap)]) - (let ([glpx (gdk_gl_pixmap_new config gdkpx #f)]) + (let ([glpx (gdk_pixmap_set_gl_capability gdkpx config #f)]) (and glpx - (let ([gl (gdk_gl_context_new glpx #f #t GDK_GL_RGBA_TYPE)]) + (let ([gl + ;; currently uses "indirect" mode --- can we + ;; reliably use direct in some environments? + (gdk_gl_context_new glpx #f #f GDK_GL_RGBA_TYPE)]) (and gl - (new gl-context% - [gl gl] - [drawable glpx]))))))))) - + (send bm install-gl-context + (new gl-context% + [gl gl] + [drawable glpx])))))))))) From 93339923eb945b33cdbb20c3271d028212bfaa3e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Oct 2010 16:43:41 -0600 Subject: [PATCH 283/462] cocoa: printer-dc% original commit: b4fafc1888795b4e6be8072db4cb7e81fa1395a6 --- collects/mred/private/wx/cocoa/cg.rkt | 1 + collects/mred/private/wx/cocoa/printer-dc.rkt | 170 +++++++++++++++++- collects/mred/private/wx/cocoa/procs.rkt | 7 +- collects/tests/gracket/draw.rkt | 3 + 4 files changed, 171 insertions(+), 10 deletions(-) diff --git a/collects/mred/private/wx/cocoa/cg.rkt b/collects/mred/private/wx/cocoa/cg.rkt index 95bd5da5..479a9dcd 100644 --- a/collects/mred/private/wx/cocoa/cg.rkt +++ b/collects/mred/private/wx/cocoa/cg.rkt @@ -11,6 +11,7 @@ (define-appserv CGContextFlush (_fun _CGContextRef -> _void)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextRotateCTM (_fun _CGContextRef _CGFloat -> _void)) (define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) (define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index 38819ef7..b56a5aec 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -1,14 +1,168 @@ #lang racket/base (require racket/class - racket/draw/dc) + racket/math + racket/draw/local + racket/draw/dc + racket/draw/cairo + racket/draw/bitmap + racket/draw/bitmap-dc + racket/draw/record-dc + racket/draw/ps-setup + ffi/unsafe + ffi/unsafe/objc + "dc.rkt" + "cg.rkt" + "utils.rkt" + "types.rkt") -(provide printer-dc%) +(provide printer-dc% + show-print-setup) -(define dc-backend% - (class default-dc-backend% - (init [parent #f]) - - (super-new))) +(import-class NSPrintOperation NSView NSGraphicsContext + NSPrintInfo NSDictionary NSPageLayout) + +(define NSPortraitOrientation 0) +(define NSLandscapeOrientation 1) + +(define-objc-class PrinterView NSView + [wxb] + [-a _BOOL (knowsPageRange: [_NSRange-pointer rng]) + (set-NSRange-location! rng 1) + (set-NSRange-length! rng (let ([wx (->wx wxb)]) + (if wx + (send wx get-page-count) + 0))) + #t] + [-a _NSRect (rectForPage: [_NSInteger n]) + (let ([wx (->wx wxb)]) + (if wx + (send wx get-rect-for-page n) + (make-NSRect (make-NSPoint 0 0) + (make-NSSize 10 10))))] + [-a _void (beginPageInRect: [_NSRect aRect] atPlacement: [_NSPoint location]) + (let ([wx (->wx wxb)]) + (when wx + (send wx start-page-at aRect))) + (super-tell #:type _void beginPageInRect: #:type _NSRect aRect atPlacement: #:type _NSPoint location)] + [-a _void (drawPageBorderWithSize: [_NSSize size]) + (let ([wx (->wx wxb)]) + (when wx + (send wx draw-print-page self size)))]) + +(define (make-print-info [prev #f]) + (as-objc-allocation-with-retain + (tell (tell NSPrintInfo alloc) + initWithDictionary: + (if prev + (tell prev dictionary) + (tell NSDictionary dictionary))))) + + +(define (install-pss-to-print-info pss print-info) + (tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape) + NSLandscapeOrientation + NSPortraitOrientation)) + (tellv print-info setScalingFactor: #:type _CGFloat (let ([x (box 0)] + [y (box 0)]) + (send pss get-scaling x y) + (unbox y)))) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [print-info (let ([pi (send pss get-native)]) + (or pi + (let ([pi (make-print-info)]) + (send pss set-native pi make-print-info) + pi)))]) + (install-pss-to-print-info pss print-info) + (tell (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + (let ([o (tell #:type _int print-info orientation)]) + (send pss set-orientation (if (= o NSLandscapeOrientation) + 'landscape + 'portrait))) + (let ([s (tell #:type _CGFloat print-info scalingFactor)]) + (send pss set-scaling s s)))) (define printer-dc% - (dc-mixin dc-backend%)) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object quartz-bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define print-info (or (let-values ([(pi copier) + (send (current-ps-setup) + get-native-copy)]) + pi) + (make-print-info))) + + (install-pss-to-print-info (current-ps-setup) print-info) + + (define-values (page-width page-height page-scaling) + (let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))] + [scaling (tell #:type _CGFloat print-info scalingFactor)]) + (values (NSSize-width s) + (NSSize-height s) + scaling))) + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define current-page 0) + + (define/public (get-page-count) (length pages)) + (define/public (get-rect-for-page i) + (make-NSRect (make-NSPoint 0 (* (sub1 i) page-height)) + (make-NSSize page-width page-height))) + (define/public (start-page-at r) + (set! current-page (inexact->exact (round (/ (NSPoint-y (NSRect-origin r)) page-height))))) + (define/public (draw-print-page view-cocoa s) + (let ([f (tell #:type _NSRect view-cocoa frame)]) + (tellv view-cocoa lockFocus) + + (let ([cg (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)] + [s (tell #:type _NSSize print-info paperSize)] + [b (tell #:type _NSRect print-info imageablePageBounds)]) + (CGContextTranslateCTM cg 0 (/ (NSSize-height s) page-scaling)) + (CGContextScaleCTM cg 1 -1) + (CGContextTranslateCTM cg + (/ (NSPoint-x (NSRect-origin b)) page-scaling) + (/ (- (NSSize-height s) + (+ (NSPoint-y (NSRect-origin b)) + (NSSize-height (NSRect-size b)))) + page-scaling)) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg + (inexact->exact (ceiling page-width)) + (inexact->exact (ceiling page-height)))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([dc (make-object (dc-mixin + (class default-dc-backend% + (define/override (get-cr) cr) + (super-new))))]) + (let ([proc (list-ref (reverse pages) current-page)]) + (proc dc))) + (cairo_destroy cr))) + + (tellv view-cocoa unlockFocus))) + + (define/override (end-doc) + (define view-cocoa (as-objc-allocation-with-retain + (tell (tell PrinterView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize 10 10))))) + (define op-cocoa (as-objc-allocation-with-retain + (tell NSPrintOperation printOperationWithView: view-cocoa + printInfo: print-info))) + + (set-ivar! view-cocoa wxb (->wxb this)) + + (tellv op-cocoa runOperation)))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index cf31e6e0..fc270957 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -11,6 +11,8 @@ "finfo.rkt" ; file-creator-and-type "filedialog.rkt" "dc.rkt" + "printer-dc.rkt" + "../common/printer.rkt" "menu-bar.rkt" "agl.rkt" "../../lock.rkt" @@ -72,7 +74,9 @@ (define-unimplemented send-event) (define (begin-refresh-sequence) (void)) (define (end-refresh-sequence) (void)) -(define-unimplemented run-printout) + +(define run-printout (make-run-printout printer-dc%)) + (define (get-double-click-time) 500) (define (get-control-font-size) 13) @@ -108,7 +112,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define (id-to-menu-item id) id) -(define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) (define/top (make-screen-bitmap [exact-positive-integer? w] diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 066da70e..38922349 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -1243,6 +1243,9 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) + (when c + (send (current-ps-setup) copy-from c))))) (make-object slider% "Alpha" 0 10 hp4 (lambda (s e) (let ([a (/ (send s get-value) 10.0)]) From 84af79f51dd7f0ece31fcacbe4d4671f95cba19b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Oct 2010 21:00:22 -0600 Subject: [PATCH 284/462] gtk: printer-dc% original commit: 5e1c4ae1f8d647d98d57888e53a016d962825148 --- collects/mred/private/wx/cocoa/printer-dc.rkt | 20 +- collects/mred/private/wx/gtk/printer-dc.rkt | 232 +++++++++++++++++- collects/mred/private/wx/gtk/procs.rkt | 9 +- collects/mred/private/wxme/editor.rkt | 4 +- 4 files changed, 244 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index b56a5aec..854a5f27 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -67,6 +67,8 @@ (send pss get-scaling x y) (unbox y)))) +(define NSOkButton 1) + (define (show-print-setup parent) (let* ([pss (current-ps-setup)] [print-info (let ([pi (send pss get-native)]) @@ -75,13 +77,17 @@ (send pss set-native pi make-print-info) pi)))]) (install-pss-to-print-info pss print-info) - (tell (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) - (let ([o (tell #:type _int print-info orientation)]) - (send pss set-orientation (if (= o NSLandscapeOrientation) - 'landscape - 'portrait))) - (let ([s (tell #:type _CGFloat print-info scalingFactor)]) - (send pss set-scaling s s)))) + (if (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (begin + (let ([o (tell #:type _int print-info orientation)]) + (send pss set-orientation (if (= o NSLandscapeOrientation) + 'landscape + 'portrait))) + (let ([s (tell #:type _CGFloat print-info scalingFactor)]) + (send pss set-scaling s s)) + #t) + #f))) (define printer-dc% (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt index 38819ef7..4cce51ef 100644 --- a/collects/mred/private/wx/gtk/printer-dc.rkt +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -1,14 +1,230 @@ #lang racket/base (require racket/class - racket/draw/dc) + racket/draw/local + racket/draw/dc + racket/draw/cairo + racket/draw/bitmap + racket/draw/bitmap-dc + racket/draw/record-dc + racket/draw/ps-setup + ffi/unsafe + ffi/unsafe/objc + ffi/unsafe/alloc + "../common/queue.rkt" + "widget.rkt" + "utils.rkt" + "types.rkt") -(provide printer-dc%) +(provide printer-dc% + show-print-setup) -(define dc-backend% - (class default-dc-backend% - (init [parent #f]) - - (super-new))) +(define GTK_UNIT_POINTS 1) + +(define GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG 0) + +(define GTK_PRINT_OPERATION_RESULT_ERROR 0) +(define GTK_PRINT_OPERATION_RESULT_APPLY 1) +(define GTK_PRINT_OPERATION_RESULT_CANCEL 2) +(define GTK_PRINT_OPERATION_RESULT_IN_PROGRESS 3) + +(define GTK_PAGE_ORIENTATION_PORTRAIT 0) +(define GTK_PAGE_ORIENTATION_LANDSCAPE 1) +(define GTK_PAGE_ORIENTATION_REVERSE_PORTRAIT 2) +(define GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE 3) + +(define _GtkPageSetup (_cpointer/null 'GtkPageSetup)) +(define _GtkPrintSettings (_cpointer/null 'GtkPrintSettings)) +(define _GtkPrintOperation _GtkWidget) ; not really, but we connect signals... +(define _GtkPrintContext (_cpointer/null 'GtkPrintContext)) + +(define-gtk gtk_page_setup_new (_fun -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define-gtk gtk_page_setup_copy (_fun _GtkPageSetup -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define allocated-page-setup ((allocator gobject-unref) values)) + +(define-gtk gtk_print_settings_new (_fun -> _GtkPrintSettings) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_page_setup_get_paper_height (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_paper_width (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_left_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_right_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_top_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_bottom_margin (_fun _GtkPageSetup _int -> _double)) + +(define-gtk gtk_page_setup_get_orientation (_fun _GtkPageSetup -> _int)) +(define-gtk gtk_page_setup_set_orientation (_fun _GtkPageSetup _int -> _void)) + +(define-gtk gtk_print_operation_new (_fun -> _GtkPrintOperation) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_print_operation_set_default_page_setup (_fun _GtkPrintOperation _GtkPageSetup + -> _void)) +(define-gtk gtk_print_operation_run (_fun _GtkPrintOperation + _int + (_or-null _GtkWindow) + (_ptr o _pointer) + -> _int)) + +(define-gtk gtk_print_operation_set_allow_async (_fun _GtkPrintOperation _gboolean -> _void)) +(define-gtk gtk_print_operation_set_n_pages (_fun _GtkPrintOperation _int -> _void)) + +(define-gtk gtk_print_context_get_cairo_context (_fun _GtkPrintContext -> _cairo_t)) + +(define-gtk gtk_print_run_page_setup_dialog_async (_fun (_or-null _GtkWindow) + _GtkPageSetup + _GtkPrintSettings + _fpointer + _pointer + -> _void)) + +(define (print-setup-done page-setup cb) + ((ptr-ref cb _racket) page-setup)) +(define print_setup_done (function-ptr print-setup-done + (_fun _GtkPageSetup _pointer -> _void))) + +(define (pss-install-page-setup pss page-setup) + (gtk_page_setup_set_orientation page-setup (if (eq? (send pss get-orientation) 'landscape) + GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_PORTRAIT))) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [page-setup (or (send pss get-native) + (let ([ps (gtk_page_setup_new)]) + (send pss set-native ps gtk_page_setup_copy) + ps))] + [print-settings (gtk_print_settings_new)] + [sema (make-semaphore)] + [done-page-setup #f] + [cell (malloc-immobile-cell (lambda (ps) + (set! done-page-setup (and ps + (allocated-page-setup ps))) + (semaphore-post sema)))]) + (pss-install-page-setup pss page-setup) + (gtk_print_run_page_setup_dialog_async (and parent + (send parent get-gtk)) + page-setup + print-settings + print_setup_done + cell) + (yield sema) + ;; `ptr-set!'s are a hack to ensure that the objects are not GCed: + (ptr-set! cell _racket page-setup) + (ptr-set! cell _racket print-settings) + (free-immobile-cell cell) + (and done-page-setup + (begin + (send pss set-native done-page-setup gtk_page_setup_copy) + (send pss set-orientation (if (member + (gtk_page_setup_get_orientation done-page-setup) + (list GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE)) + 'landscape + 'portrait)) + #t)))) + +(define-signal-handler connect-begin-print "begin-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (void))) + +(define-signal-handler connect-draw-page "draw-page" + (_fun _GtkPrintOperation _GtkPrintContext _int -> _void) + (lambda (op-gtk ctx-gtk page-no) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx draw-page ctx-gtk page-no))))) + +(define-signal-handler connect-done "done" + (_fun _GtkPrintOperation _int -> _void) + (lambda (op-gtk res) + (when (= res GTK_PRINT_OPERATION_RESULT_CANCEL) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done)))))) + +(define-signal-handler connect-end-print "end-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done))))) + +(define printout% + (class widget% + (init-field op-gtk + pages + page-setup) + (super-new [gtk op-gtk]) + + (connect-begin-print op-gtk) + (connect-draw-page op-gtk) + (connect-done op-gtk) + (connect-end-print op-gtk) + + (gtk_print_operation_set_n_pages op-gtk (length pages)) + (gtk_print_operation_set_allow_async op-gtk #t) + (gtk_print_operation_set_default_page_setup op-gtk page-setup) + + (define done-sema (make-semaphore)) + + (define/public (go) + (let ([res (gtk_print_operation_run op-gtk + GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG + #f)]) + (yield done-sema))) + + (define/public (draw-page ctx-gtk pageno) + (let ([cr (gtk_print_context_get_cairo_context ctx-gtk)]) + ((list-ref pages pageno) + (make-object + (class (dc-mixin default-dc-backend%) + (super-new) + (define orig-matrix (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)) + (cairo_get_matrix cr orig-matrix) + (define/override (init-cr-matrix cr) (cairo_set_matrix cr orig-matrix)) + (define/override (get-cr) cr)))))) + + (define/public (done) + (semaphore-post done-sema)))) (define printer-dc% - (dc-mixin dc-backend%)) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define page-setup (or (let-values ([(ps copier) + (send (current-ps-setup) + get-native-copy)]) + ps) + (gtk_page_setup_new))) + (pss-install-page-setup (current-ps-setup) page-setup) + + (define page-width (- (gtk_page_setup_get_paper_width page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_left_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_right_margin page-setup GTK_UNIT_POINTS))) + (define page-height (- (gtk_page_setup_get_paper_height page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_top_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_bottom_margin page-setup GTK_UNIT_POINTS))) + (define page-scaling 1.0) ; scale from gtk_print_operation_run is too late + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define/override (end-doc) + (send (new printout% + [op-gtk (gtk_print_operation_new)] + [pages (reverse pages)] + [page-setup page-setup]) + go)))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 6b77bd50..ad1687fd 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -11,7 +11,9 @@ "widget.rkt" "window.rkt" "dc.rkt" + "printer-dc.rkt" "gl-context.rkt" + "../common/printer.rkt" "../common/handlers.rkt") (provide @@ -72,7 +74,9 @@ (case-lambda [(path cr ty) (void)] [(path) (values #"????" #"????")])) -(define-unimplemented run-printout) + +(define run-printout (make-run-printout printer-dc%)) + (define (get-double-click-time) 250) (define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 10) ;; FIXME @@ -101,8 +105,7 @@ (define-unimplemented is-color-display?) (define (id-to-menu-item i) i) -(define-unimplemented show-print-setup) -(define (can-show-print-setup?) #f) +(define (can-show-print-setup?) #t) (define (get-highlight-background-color) (let-values ([(r g b) (get-selected-background-color)]) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 27138274..0c10ec66 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -744,9 +744,7 @@ [any? [parent #f]] ; checked in ../editor.ss [bool? [force-page-bbox? #t]] [bool? [as-eps? #f]]) - (let ([ps? (case (system-type) - [(macosx windows) (eq? output-mode 'postscript)] - [else #t])] + (let ([ps? (eq? output-mode 'postscript)] [parent (or parent (extract-parent))]) (cond From 198173e6374b3fe73bd74b3dc374103a3b0b010a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Oct 2010 21:03:25 -0600 Subject: [PATCH 285/462] remove accidental objc dependency original commit: 77399ddaf76691696e26fb3e7a3e4beefa3c4799 --- collects/mred/private/wx/gtk/printer-dc.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt index 4cce51ef..d72a47fa 100644 --- a/collects/mred/private/wx/gtk/printer-dc.rkt +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -8,7 +8,6 @@ racket/draw/record-dc racket/draw/ps-setup ffi/unsafe - ffi/unsafe/objc ffi/unsafe/alloc "../common/queue.rkt" "widget.rkt" From 75adf058a15bb80ea3c4986d16ef70a7bfb5a409 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 21:22:20 -0600 Subject: [PATCH 286/462] win32: gl bitmaps original commit: b98ba3e60b5173dec8f6ca6970592c8ab2441046 --- collects/mred/private/wx/win32/dc.rkt | 10 +++++++++- collects/mred/private/wx/win32/procs.rkt | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 9c14dc1f..51e3fc86 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -21,7 +21,7 @@ (define win32-bitmap% (class bitmap% - (init w h hwnd) + (init w h hwnd [gl-config #f]) (super-make-object (make-alternate-bitmap-kind w h)) (define s @@ -40,6 +40,14 @@ (cairo_paint cr) (cairo_destroy cr)) s)) + + (define gl (and gl-config + (let ([hdc (cairo_win32_surface_get_dc s)]) + (set-cpointer-tag! hdc 'HDC) + (create-gl-context hdc + gl-config + #t)))) + (define/override (get-bitmap-gl-context) gl) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 9659eb6f..cf34f38a 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -106,6 +106,6 @@ (define/top (make-gl-bitmap [exact-positive-integer? w] [exact-positive-integer? h] [gl-config% c]) - (make-object win32-bitmap% w h #f)) + (make-object win32-bitmap% w h #f c)) (define (check-for-break) #f) From a5dcb6bf93cd4e74b9c2d406ea892fd01e69e7c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 06:54:39 -0600 Subject: [PATCH 287/462] win32: printer-dc% original commit: c996185ea5fd5ad86822152e0fa45eba46062794 --- collects/mred/private/wx/win32/printer-dc.rkt | 220 +++++++++++++++++- collects/mred/private/wx/win32/procs.rkt | 10 +- 2 files changed, 219 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/win32/printer-dc.rkt b/collects/mred/private/wx/win32/printer-dc.rkt index 38819ef7..7118d219 100644 --- a/collects/mred/private/wx/win32/printer-dc.rkt +++ b/collects/mred/private/wx/win32/printer-dc.rkt @@ -1,14 +1,218 @@ #lang racket/base (require racket/class - racket/draw/dc) + ffi/unsafe + ffi/unsafe/alloc + racket/draw/dc + racket/draw/local + racket/draw/cairo + racket/draw/record-dc + racket/draw/bitmap-dc + racket/draw/ps-setup + "../../lock.rkt" + "dc.rkt" + "types.rkt" + "utils.rkt" + "const.rkt") -(provide printer-dc%) +(provide printer-dc% + show-print-setup) -(define dc-backend% - (class default-dc-backend% - (init [parent #f]) - - (super-new))) +(define _HGLOBAL _pointer) + +(define-cstruct _PAGESETUPDLG + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hDevMode _HGLOBAL] + [hDevNames _HGLOBAL] + [Flags _DWORD] + [ptPaperSize _POINT] + [rtMinMargin _RECT] + [rtMargin _RECT] + [hInstance _HINSTANCE] + [lCustData _LPARAM] + [lpfnPageSetupHook _fpointer] + [lpfnPagePaintHook _fpointer] + [lpPageSetupTemplateName _pointer] + [hPageSetupTemplate _HGLOBAL])) + +(define-cstruct _PRINTDLG + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hDevMode _HGLOBAL] + [hDevNames _HGLOBAL] + [hDC _HDC] + [Flags _DWORD] + [nFromPage _WORD] + [nToPage _WORD] + [nMinPage _WORD] + [nMaxPage _WORD] + [nCopies _WORD] + [hInstance _HINSTANCE] + [lCustData _LPARAM] + [lpfnPrintHook _fpointer] + [lpfnSetupHook _fpointer] + [lpPrintTemplateName _pointer] + [lpSetupTemplateName _pointer] + [hPrintTemplate _HGLOBAL] + [hSetupTemplate _HGLOBAL]) + #:alignment 2) + +(define-cstruct _DOCINFO + ([cbSize _int] + [lpszDocName _permanent-string/utf-16] + [lpszOutput _pointer] + [lpszDatatype _pointer] + [fwType _DWORD])) + +(define PD_RETURNDC #x00000100) + +(define PSD_INTHOUSANDTHSOFINCHES #x00000004) +(define PSD_INHUNDREDTHSOFMILLIMETERS #x00000008) + +(define-comdlg32 PageSetupDlgW (_wfun _PAGESETUPDLG-pointer -> _BOOL)) +(define-comdlg32 PrintDlgW (_wfun _PRINTDLG-pointer -> _BOOL)) + +(define-gdi32 StartDocW (_wfun _HDC _DOCINFO-pointer -> _int)) +(define-gdi32 StartPage (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'StartPage)))) +(define-gdi32 EndPage (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndPage)))) +(define-gdi32 EndDoc (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndDoc)))) + +(define needs-delete ((allocator DeleteDC) values)) + +(define (clone-page-setup p) + (let ([new-p (malloc 1 _PAGESETUPDLG)]) + (set-cpointer-tag! new-p PAGESETUPDLG-tag) + (memcpy new-p 0 p 1 _PAGESETUPDLG) + new-p)) + +(define PSD_RETURNDEFAULT #x00000400) + +(define (show-print-setup parent [just-create? #f]) + (let* ([pss (current-ps-setup)] + [ps (send pss get-native)]) + (atomically + (let ([p (malloc 'raw 1 _PAGESETUPDLG)]) + (set-cpointer-tag! p PAGESETUPDLG-tag) + (if ps + (memcpy p 0 ps 1 _PAGESETUPDLG) + (begin + (memset p 0 1 _PAGESETUPDLG) + (set-PAGESETUPDLG-lStructSize! p (ctype-sizeof _PAGESETUPDLG)))) + (set-PAGESETUPDLG-Flags! p (if just-create? + PSD_RETURNDEFAULT + 0)) + (let ([r (PageSetupDlgW p)]) + (when r + (let ([new-p (clone-page-setup p)]) + (send pss set-native new-p values))) + (free p) + ;; FIXME: `r' leaks handles through + ;; the hDevModes and hDevNames fields + r))))) (define printer-dc% - (dc-mixin dc-backend%)) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object win32-bitmap% 1 1 #f)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define page-setup (or (send (current-ps-setup) get-native) + (begin + (show-print-setup #f #t) + (send (current-ps-setup) get-native)))) + + (define-values (page-width page-height) + (let ([scale (if (zero? (bitwise-and (PAGESETUPDLG-Flags page-setup) + PSD_INTHOUSANDTHSOFINCHES)) + ;; 100ths of mm + (/ 72.0 (/ 10.0 2.54)) + ;; 1000ths of in + (/ 72.0 1000.0))]) + (values + (* scale (POINT-x (PAGESETUPDLG-ptPaperSize page-setup))) + (* scale (POINT-y (PAGESETUPDLG-ptPaperSize page-setup)))))) + + + + (define/override (get-size) (values page-width page-height)) + + (define start-doc-message #f) + (define/override (start-doc s) + (super start-doc s) + (set! start-doc-message (and s (string->immutable-string s)))) + + (define/override (end-doc) + (let-values ([(hdc from-page to-page) + (atomically + (let ([p (malloc 'raw 1 _PRINTDLG)]) + (set-cpointer-tag! p PRINTDLG-tag) + (memset p 0 1 _PRINTDLG) + (set-PRINTDLG-lStructSize! p (ctype-sizeof _PRINTDLG)) + (set-PRINTDLG-hDevMode! p (PAGESETUPDLG-hDevMode page-setup)) + (set-PRINTDLG-hDevNames! p (PAGESETUPDLG-hDevNames page-setup)) + (set-PRINTDLG-Flags! p (bitwise-ior PD_RETURNDC)) + (set-PRINTDLG-nFromPage! p 1) + (set-PRINTDLG-nToPage! p (length pages)) + (set-PRINTDLG-nMinPage! p 1) + (set-PRINTDLG-nMaxPage! p (length pages)) + (set-PRINTDLG-nCopies! p 1) + (let ([r (PrintDlgW p)]) + (begin0 + (if r + (values (needs-delete (PRINTDLG-hDC p)) + (PRINTDLG-nFromPage p) + (PRINTDLG-nToPage p)) + (values #f #f #f)) + (free p)))))]) + (when hdc + (atomically + (let ([job + (let ([di (make-DOCINFO (ctype-sizeof _DOCINFO) + start-doc-message + #f + #f + 0)]) + (begin0 + (StartDocW hdc di) + (when start-doc-message + (free (DOCINFO-lpszDocName di)))))]) + (when (positive? job) + (for ([proc (in-list (reverse pages))] + [page-no (in-naturals 1)]) + (when (<= from-page page-no to-page) + (StartPage hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create s)]) + (set-point-scale hdc cr) + (proc + (make-object + (class (dc-mixin default-dc-backend%) + (super-new) + (define/override (init-cr-matrix cr) + (set-point-scale hdc cr)) + (define/override (get-cr) cr)))) + (cairo_destroy cr) + (cairo_surface_destroy s)) + (EndPage hdc))) + (EndDoc hdc)) + (DeleteDC hdc)))))))) + +(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) + +(define LOGPIXELSX 88) +(define LOGPIXELSY 90) + +(define (set-point-scale hdc cr) + (let* ([lpx (GetDeviceCaps hdc LOGPIXELSX)] + [lpy (GetDeviceCaps hdc LOGPIXELSY)] + [lx (/ (if (zero? lpx) 300 lpx) 72.0)] + [ly (/ (if (zero? lpy) 300 lpy) 72.0)]) + (cairo_scale cr lx ly))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index cf34f38a..b86e74d2 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -9,6 +9,8 @@ "menu-item.rkt" "frame.rkt" "dc.rkt" + "printer-dc.rkt" + "../common/printer.rkt" "filedialog.rkt" racket/draw) @@ -70,7 +72,9 @@ (define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) -(define-unimplemented run-printout) + +(define run-printout (make-run-printout printer-dc%)) + (define (get-double-click-time) 500) (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) @@ -89,8 +93,8 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) -(define-unimplemented show-print-setup) -(define (can-show-print-setup?) #f) + +(define (can-show-print-setup?) #t) (define (get-highlight-background-color) (let ([c (GetSysColor COLOR_HIGHLIGHT)]) From 3740a947adf893498f8ff50af35dc0217ff92698 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 08:45:06 -0600 Subject: [PATCH 288/462] cocoa & gtk: color dialog original commit: 18c99e52a5315dddbf61ae12de278ba28133f68c --- collects/mred/private/moredialogs.rkt | 61 +++++++++---- .../mred/private/wx/cocoa/colordialog.rkt | 43 +++++++++ collects/mred/private/wx/cocoa/frame.rkt | 9 +- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 26 +++--- collects/mred/private/wx/cocoa/slider.rkt | 6 +- collects/mred/private/wx/cocoa/window.rkt | 8 +- .../mred/private/wx/common/default-procs.rkt | 32 +++++++ collects/mred/private/wx/common/queue.rkt | 31 ++++--- collects/mred/private/wx/gtk/canvas.rkt | 5 -- collects/mred/private/wx/gtk/colordialog.rkt | 37 ++++++++ collects/mred/private/wx/gtk/filedialog.rkt | 89 ++++++------------- collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 30 +++---- collects/mred/private/wx/gtk/stddialog.rkt | 54 +++++++++++ collects/mred/private/wx/gtk/style.rkt | 6 -- collects/mred/private/wx/gtk/types.rkt | 9 +- collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 27 +++--- 20 files changed, 328 insertions(+), 149 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/colordialog.rkt create mode 100644 collects/mred/private/wx/common/default-procs.rkt create mode 100644 collects/mred/private/wx/gtk/colordialog.rkt create mode 100644 collects/mred/private/wx/gtk/stddialog.rkt diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 8f275043..1ee3068d 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -284,32 +284,58 @@ (check-top-level-parent/false 'get-color-from-user parent) (check-instance 'get-color-from-user wx:color% 'color% #t color) (check-style 'get-color-from-user #f null style) - (if (not (eq? (system-type) 'unix)) + (if (eq? (wx:color-from-user-platform-mode) 'dialog) (wx:get-color-from-user message (and parent (mred->wx parent)) color) (letrec ([ok? #f] [f (make-object dialog% "Choose Color" parent)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [canvas (make-object (class canvas% (define/override (on-paint) - (repaint #f #f)) + (repaint void)) (super-new [parent f])))] + [platform-p (and (string? (wx:color-from-user-platform-mode)) + (new horizontal-panel% + [parent f] + [alignment '(right center)]))] [p (make-object vertical-pane% f)] - [repaint (lambda (s e) - (let ([c (make-object wx:color% - (send red get-value) - (send green get-value) - (send blue get-value))]) - (wx:fill-private-color (send canvas get-dc) c)))] - [make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))] + [repaint (lambda (ext) + (let ([c (get-current-color)]) + (ext c) + (wx:fill-private-color (send canvas get-dc) c)))] + [update-and-repaint (lambda (s e) + (repaint + (lambda (c) + (when platform-p + (wx:get-color-from-user c)))))] + [make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))] [red (make-color-slider "Red:")] [green (make-color-slider "Green:")] [blue (make-color-slider "Blue:")] - [bp (make-object horizontal-pane% f)]) - (when color - (send red set-value (send color red)) - (send green set-value (send color green)) - (send blue set-value (send color blue))) - (ok-cancel + [bp (make-object horizontal-pane% f)] + [get-current-color + (lambda () + (make-object wx:color% + (send red get-value) + (send green get-value) + (send blue get-value)))] + [install-color + (lambda (color) + (send red set-value (send color red)) + (send green set-value (send color green)) + (send blue set-value (send color blue)) + (send canvas refresh))]) + (when platform-p + (new button% + [parent platform-p] + [label (wx:color-from-user-platform-mode)] + [callback (lambda (b e) (wx:get-color-from-user 'show))]) + (wx:get-color-from-user (or color + (make-object wx:color% 0 0 0))) + (send (mred->wx f) set-color-callback (lambda () + (install-color + (wx:get-color-from-user 'get))))) + (when color (install-color color)) + (ok-cancel (lambda () (make-object button% "Cancel" bp (done #f))) (lambda () @@ -321,7 +347,4 @@ (send f center) (send f show #t) (and ok? - (make-object wx:color% - (send red get-value) - (send green get-value) - (send blue get-value)))))]))) + (get-current-color))))]))) diff --git a/collects/mred/private/wx/cocoa/colordialog.rkt b/collects/mred/private/wx/cocoa/colordialog.rkt new file mode 100644 index 00000000..1f3a8e6b --- /dev/null +++ b/collects/mred/private/wx/cocoa/colordialog.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/draw/color + "../../lock.rkt" + "utils.rkt" + "types.rkt") + +(provide get-color-from-user) + +(import-class NSColorPanel + NSColor) + +(define-cocoa NSDeviceRGBColorSpace _id) + +(define (get-color-from-user mode) + (cond + [(eq? mode 'show) + (tellv (tell NSColorPanel sharedColorPanel) + orderFront: #f)] + [(eq? mode 'get) + (atomically + (let ([c (tell (tell (tell NSColorPanel sharedColorPanel) color) + colorUsingColorSpaceName: NSDeviceRGBColorSpace)] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (make-object color% + (as-color + (tell #:type _CGFloat c redComponent)) + (as-color + (tell #:type _CGFloat c greenComponent)) + (as-color + (tell #:type _CGFloat c blueComponent)))))] + [else + (let ([p (tell NSColorPanel sharedColorPanel)] + [color mode]) + (atomically + (tellv p setColor: (tell NSColor + colorWithDeviceRed: #:type _CGFloat (/ (color-red color) 255.0) + green: #:type _CGFloat (/ (color-green color) 255.0) + blue: #:type _CGFloat (/ (color-blue color) 255.0) + alpha: #:type _CGFloat 1.0))))])) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index b575f3bb..7daf05d9 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -496,7 +496,14 @@ (tellv cocoa miniaturize: cocoa)) (define/public (set-title s) - (tellv cocoa setTitle: #:type _NSString s)))) + (tellv cocoa setTitle: #:type _NSString s)) + + + (define color-callback void) + (define/public (set-color-callback cb) + (set! color-callback cb)) + (define/override (on-color-change) + (queue-window-event this (lambda () (color-callback)))))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 5dcb42bf..04bd876f 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -79,6 +79,7 @@ play-sound get-panel-background get-font-from-user + color-from-user-platform-mode get-color-from-user special-option-key special-control-key diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index fc270957..d0167568 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -10,19 +10,26 @@ "window.rkt" "finfo.rkt" ; file-creator-and-type "filedialog.rkt" + "colordialog.rkt" "dc.rkt" "printer-dc.rkt" "../common/printer.rkt" "menu-bar.rkt" "agl.rkt" "../../lock.rkt" - "../common/handlers.rkt") + "../common/handlers.rkt" + (except-in "../common/default-procs.rkt" + special-control-key + special-option-key + file-creator-and-type)) + (provide application-file-handler application-quit-handler application-about-handler application-pref-handler + color-from-user-platform-mode get-color-from-user get-font-from-user get-panel-background @@ -60,20 +67,20 @@ (import-class NSScreen NSCursor) - -(define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) -(define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) +(define-unimplemented send-event) +(define-unimplemented write-resource) +(define-unimplemented get-resource) + +(define (color-from-user-platform-mode) "Show Picker") + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [x #f]) #f) -(define-unimplemented send-event) -(define (begin-refresh-sequence) (void)) -(define (end-refresh-sequence) (void)) (define run-printout (make-run-printout printer-dc%)) @@ -82,9 +89,6 @@ (define (get-control-font-size) 13) (define (get-control-font-size-in-pixels?) #f) (define (cancel-quit) (void)) -(define-unimplemented fill-private-color) -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define (check-for-break) #f) @@ -110,7 +114,7 @@ (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) (define (get-display-depth) 32) -(define-unimplemented is-color-display?) +(define (is-color-display?) #t) (define (id-to-menu-item id) id) (define (can-show-print-setup?) #t) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 477cd96d..35170d85 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -52,8 +52,10 @@ (tellv cocoa setMinValue: #:type _double* lo) (tellv cocoa setMaxValue: #:type _double* hi) (tellv cocoa setDoubleValue: #:type _double* val) - (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) - (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) + ;; heuristic: show up to tick marks: + (when ((- hi lo) . < . 64) + (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) + (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t)) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize (if vert? 24 32) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 1ae62f73..6a04a6e9 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -68,7 +68,10 @@ (and (super-tell resignFirstResponder) (let ([wx (->wx wxb)]) (when wx (send wx is-responder wx #f)) - #t))]) + #t))] + [-a _void (changeColor: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx (send wx on-color-change)))]) (import-class NSArray) (import-protocol NSTextInput) @@ -702,6 +705,9 @@ (define/public (gets-focus?) #f) (define/public (can-be-responder?) #t) + + (define/public (on-color-change) + (send parent on-color-change)) (def/public-unimplemented centre))) diff --git a/collects/mred/private/wx/common/default-procs.rkt b/collects/mred/private/wx/common/default-procs.rkt new file mode 100644 index 00000000..5034f1be --- /dev/null +++ b/collects/mred/private/wx/common/default-procs.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require racket/class + racket/draw/color) +(provide special-control-key + special-option-key + file-creator-and-type + get-panel-background + fill-private-color) + +(define special-control-key? #f) +(define special-control-key + (case-lambda + [() special-control-key?] + [(on?) (set! special-control-key? (and on? #t))])) + +(define special-option-key? #f) +(define special-option-key + (case-lambda + [() special-option-key?] + [(on?) (set! special-option-key? (and on? #t))])) + +(define file-creator-and-type + (case-lambda + [(path cr ty) (void)] + [(path) (values #"????" #"????")])) + +(define (get-panel-background) + (make-object color% "gray")) + +(define (fill-private-color dc col) + (send dc set-background col) + (send dc clear)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 5a26a8d5..e99d411a 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -31,6 +31,7 @@ eventspace-handler-thread eventspace-wait-cursor-count eventspace-extra-table + eventspace-adjust-external-modal! queue-callback middle-queue-key @@ -153,7 +154,8 @@ [shutdown? #:mutable] done-sema [wait-cursor-count #:mutable] - extra-table) + extra-table + [external-modal #:mutable]) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -318,7 +320,8 @@ #f done-sema 0 - (make-hash))] + (make-hash) + 0)] [cb-box (box #f)]) (parameterize ([current-cb-box cb-box]) (scheme_add_managed (current-custodian) @@ -437,14 +440,22 @@ (lambda (k v) k))) (define (other-modal? win) - ;; called in atmoic mode in eventspace's thread - (let loop ([frames (get-top-level-windows)]) - (and (pair? frames) - (let ([status (send (car frames) frame-relative-dialog-status win)]) - (case status - [(#f) (loop (cdr frames))] - [(same) #f] - [(other) #t]))))) + ;; called in atomic mode in eventspace's thread + (let ([es (send win get-eventspace)]) + (or (positive? (eventspace-external-modal es)) + (let loop ([frames (get-top-level-windows es)]) + (and (pair? frames) + (let ([status (send (car frames) frame-relative-dialog-status win)]) + (case status + [(#f) (loop (cdr frames))] + [(same) #f] + [(other) #t]))))))) + +(define (eventspace-adjust-external-modal! es amt) + (atomically + (set-eventspace-external-modal! + es + (+ (eventspace-external-modal es) amt)))) (define (queue-quit-event) ;; called in event-pump thread diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index c9d80e41..e41491ad 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -98,11 +98,6 @@ (define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) #:c-id g_object_set) -(define-cstruct _GdkColor ([pixel _uint32] - [red _uint16] - [green _uint16] - [blue _uint16])) - (define-gdk gdk_gc_unref (_fun _pointer -> _void) #:wrap (deallocator)) (define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) diff --git a/collects/mred/private/wx/gtk/colordialog.rkt b/collects/mred/private/wx/gtk/colordialog.rkt new file mode 100644 index 00000000..c836da71 --- /dev/null +++ b/collects/mred/private/wx/gtk/colordialog.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw/color + "types.rkt" + "utils.rkt" + "stddialog.rkt") + +(provide get-color-from-user) + +(define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget)) + +(define-gtk gtk_color_selection_dialog_get_color_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_color_selection_get_current_color (_fun _GtkWidget (c : (_ptr o _GdkColor)) -> _void -> c)) +(define-gtk gtk_color_selection_set_current_color (_fun _GtkWidget _GdkColor-pointer -> _void)) + +(define (get-color-from-user message parent color) + (let ([d (as-gtk-window-allocation + (gtk_color_selection_dialog_new (or message "Choose Color")))] + [to-gdk (lambda (c) (arithmetic-shift c 8))]) + (when color + (gtk_color_selection_set_current_color + (gtk_color_selection_dialog_get_color_selection d) + (make-GdkColor + 0 + (to-gdk (color-red color)) + (to-gdk (color-green color)) + (to-gdk (color-blue color))))) + (and (eq? (show-dialog d) 'ok) + (let ([c (gtk_color_selection_get_current_color + (gtk_color_selection_dialog_get_color_selection d))]) + (make-object color% + (arithmetic-shift (GdkColor-red c) -8) + (arithmetic-shift (GdkColor-green c) -8) + (arithmetic-shift (GdkColor-blue c) -8)))))) + + \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt index 6423f7e9..e25a0cd8 100644 --- a/collects/mred/private/wx/gtk/filedialog.rkt +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -8,6 +8,7 @@ "utils.rkt" "widget.rkt" "queue.rkt" + "stddialog.rkt" "../common/handlers.rkt" "../common/queue.rkt") @@ -18,20 +19,6 @@ (define _GtkFileChooserAction (_enum (list 'open 'save 'select-folder 'create-folder))) -(define _GtkResponse - (_enum - '(none = -1 - reject = -2 - accept = -3 - delete-event = -4 - ok = -5 - cancel = -6 - close = -7 - yes = -8 - no = -9 - apply = -10 - help = -11) - _fixint)) ;; FIXME: really there are varargs here, but we don't need them for ;; our purposes (define-gtk gtk_file_chooser_dialog_new @@ -69,21 +56,22 @@ extension ;; always ignored filters style parent) (define type (car style)) ;; the rest of `style' is irrelevant on Gtk - (define dlg (gtk_file_chooser_dialog_new - message (and parent (send parent get-gtk)) - (case type - [(dir) 'select-folder] - [(put) 'save] - [else 'open]) - "gtk-cancel" 'cancel - ;; no stock names for "Select" - (case type - [(dir) "Choose"] - [(put) "gtk-save"] - [(get) "gtk-open"] - [(multi) "Choose"]) - 'accept - #f)) + (define dlg (as-gtk-window-allocation + (gtk_file_chooser_dialog_new + message (and parent (send parent get-gtk)) + (case type + [(dir) 'select-folder] + [(put) 'save] + [else 'open]) + "gtk-cancel" 'cancel + ;; no stock names for "Select" + (case type + [(dir) "Choose"] + [(put) "gtk-save"] + [(get) "gtk-open"] + [(multi) "Choose"]) + 'accept + #f))) (when (eq? 'multi type) (gtk_file_chooser_set_select_multiple dlg #t)) (when filename @@ -97,15 +85,15 @@ (gtk_file_filter_set_name ff name) (gtk_file_filter_add_pattern ff glob) (gtk_file_chooser_add_filter dlg ff))])) - (define ans (and (= -3 (show-dialog dlg - (lambda (v) - (or (not (= v -3)) - ;; FIXME: for get mode, probably should check file vs. - ;; directory name - (not (eq? type 'put)) - (not (file-exists? (gtk_file_chooser_get_filename dlg))) - ;; FIXME: need to ask "replace the file? here - #t)))) + (define ans (and (eq? 'accept (show-dialog dlg + (lambda (v) + (or (not (eq? v 'accept)) + ;; FIXME: for get mode, probably should check file vs. + ;; directory name + (not (eq? type 'put)) + (not (file-exists? (gtk_file_chooser_get_filename dlg))) + ;; FIXME: need to ask "replace the file? here + #t)))) (if (eq? type 'multi) (gtk_file_chooser_get_filenames dlg) (gtk_file_chooser_get_filename dlg)))) @@ -113,28 +101,3 @@ ans) (define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) - -(define-signal-handler connect-response "response" - (_fun _GtkWidget _int _pointer -> _void) - (lambda (gtk id data) - (let* ([p (ptr-ref data _racket)] - [response-sema (car p)] - [response-box (cdr p)]) - (set-box! response-box id) - (semaphore-post response-sema)))) - -(define (show-dialog dlg-gtk - [validate? (lambda (val) #t)]) - (let* ([response-sema (make-semaphore)] - [response-box (box #f)] - [cell (malloc-immobile-cell (cons response-sema - response-box))]) - (connect-response dlg-gtk cell) - (gtk_widget_show dlg-gtk) - (let loop () - (yield response-sema) - (unless (validate? (unbox response-box)) - (loop))) - (free-immobile-cell cell) ;; FIXME : don't leak - (gtk_widget_hide dlg-gtk) - (unbox response-box))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index d71e484a..712f2f3f 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -79,6 +79,7 @@ play-sound get-panel-background get-font-from-user + color-from-user-platform-mode get-color-from-user special-option-key special-control-key diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index ad1687fd..e300a5c4 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -5,6 +5,7 @@ racket/class racket/draw "filedialog.rkt" + "colordialog.rkt" "types.rkt" "utils.rkt" "style.rkt" @@ -14,12 +15,14 @@ "printer-dc.rkt" "gl-context.rkt" "../common/printer.rkt" + "../common/default-procs.rkt" "../common/handlers.rkt") (provide special-control-key special-option-key get-color-from-user + color-from-user-platform-mode get-font-from-user get-panel-background play-sound @@ -56,36 +59,29 @@ make-gl-bitmap check-for-break) -(define-unimplemented special-control-key) -(define (special-option-key on?) (void)) -(define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) -(define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) +(define-unimplemented location->window) +(define-unimplemented send-event) +(define-unimplemented key-symbol-to-integer) +(define-unimplemented cancel-quit) +(define-unimplemented write-resource) +(define-unimplemented get-resource) + +(define (color-from-user-platform-mode) 'dialog) + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [mbar? #f]) #t) -(define-unimplemented location->window) -(define-unimplemented send-event) -(define file-creator-and-type - (case-lambda - [(path cr ty) (void)] - [(path) (values #"????" #"????")])) (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 250) -(define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 10) ;; FIXME (define (get-control-font-size-in-pixels?) #f) ;; FIXME -(define-unimplemented cancel-quit) -(define-unimplemented fill-private-color) - -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) (define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) @@ -102,7 +98,7 @@ (define (hide-cursor) (void)) -(define-unimplemented is-color-display?) +(define (is-color-display?) #t) (define (id-to-menu-item i) i) (define (can-show-print-setup?) #t) diff --git a/collects/mred/private/wx/gtk/stddialog.rkt b/collects/mred/private/wx/gtk/stddialog.rkt new file mode 100644 index 00000000..49d6449b --- /dev/null +++ b/collects/mred/private/wx/gtk/stddialog.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "types.rkt" + "utils.rkt" + "widget.rkt" + "queue.rkt" + "../common/queue.rkt") + +(provide show-dialog + _GtkResponse) + +(define _GtkResponse + (_enum + '(none = -1 + reject = -2 + accept = -3 + delete-event = -4 + ok = -5 + cancel = -6 + close = -7 + yes = -8 + no = -9 + apply = -10 + help = -11) + _fixint)) + +(define-signal-handler connect-response "response" + (_fun _GtkWidget _GtkResponse _pointer -> _void) + (lambda (gtk id data) + (let* ([p (ptr-ref data _racket)] + [response-sema (car p)] + [response-box (cdr p)]) + (set-box! response-box id) + (semaphore-post response-sema)))) + +(define (show-dialog dlg-gtk + [validate? (lambda (val) #t)]) + (let* ([response-sema (make-semaphore)] + [response-box (box #f)] + [cell (malloc-immobile-cell (cons response-sema + response-box))] + [es (current-eventspace)]) + (connect-response dlg-gtk cell) + (eventspace-adjust-external-modal! es 1) + (gtk_widget_show dlg-gtk) + (let loop () + (yield response-sema) + (unless (validate? (unbox response-box)) + (loop))) + (eventspace-adjust-external-modal! es -1) + (free-immobile-cell cell) ;; FIXME : don't leak + (gtk_widget_hide dlg-gtk) + (unbox response-box))) diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt index f5d41e6b..808f585a 100644 --- a/collects/mred/private/wx/gtk/style.rkt +++ b/collects/mred/private/wx/gtk/style.rkt @@ -7,12 +7,6 @@ (provide get-selected-text-color get-selected-background-color) -(define-cstruct _GdkColor - ([pixel _uint32] - [red _uint16] - [green _uint16] - [blue _uint16])) - (define-cstruct _GTypeInstance ([class _pointer])) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 7ba1ab7b..8bb4f761 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -27,7 +27,9 @@ (struct-out GdkEventConfigure) _GdkEventExpose _GdkEventExpose-pointer (struct-out GdkEventExpose) - (struct-out GdkRectangle)) + (struct-out GdkRectangle) + _GdkColor _GdkColor-pointer + (struct-out GdkColor)) (define _GType _long) @@ -131,3 +133,8 @@ [area _GdkRectangle] [region _pointer] [count _int])) + +(define-cstruct _GdkColor ([pixel _uint32] + [red _uint16] + [green _uint16] + [blue _uint16])) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 6375991f..4d63680b 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -64,6 +64,7 @@ play-sound get-panel-background get-font-from-user + color-from-user-platform-mode get-color-from-user special-option-key special-control-key diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 2a71e0e2..9caeea00 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -80,6 +80,7 @@ play-sound get-panel-background get-font-from-user + color-from-user-platform-mode get-color-from-user special-option-key special-control-key diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index b86e74d2..0a9e58cb 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -11,6 +11,8 @@ "dc.rkt" "printer-dc.rkt" "../common/printer.rkt" + (except-in "../common/default-procs.rkt" + get-panel-background) "filedialog.rkt" racket/draw) @@ -18,6 +20,7 @@ special-control-key special-option-key get-color-from-user + color-from-user-platform-mode get-font-from-user get-panel-background play-sound @@ -53,36 +56,34 @@ make-gl-bitmap check-for-break) -(define-unimplemented special-control-key) -(define-unimplemented special-option-key) -(define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) +(define-unimplemented play-sound) +(define-unimplemented find-graphical-system-path) +(define-unimplemented location->window) +(define-unimplemented send-event) +(define-unimplemented cancel-quit) +(define-unimplemented write-resource) +(define-unimplemented get-resource) + +(define-unimplemented get-color-from-user) +(define (color-from-user-platform-mode) #f) (define (get-panel-background) (let ([c (GetSysColor COLOR_BTNFACE)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) -(define-unimplemented play-sound) -(define-unimplemented find-graphical-system-path) (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [? #f]) #t) -(define-unimplemented location->window) -(define-unimplemented send-event) -(define-unimplemented file-creator-and-type) (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 500) (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) -(define-unimplemented cancel-quit) -(define-unimplemented fill-private-color) (define (flush-display) (void)) -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define-user32 MessageBeep (_wfun _UINT -> _BOOL)) (define (bell) @@ -92,7 +93,7 @@ (define (get-display-depth) 32) -(define-unimplemented is-color-display?) +(define (is-color-display?) #t) (define (can-show-print-setup?) #t) From b205bfc087011ddcb013ff17be9f38e4be0b43bd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 08:59:24 -0600 Subject: [PATCH 289/462] win32: color dialog original commit: 6b5c7e88a02a53a75ffec5ab6d18124f5ffbfb64 --- .../mred/private/wx/win32/colordialog.rkt | 52 +++++++++++++++++++ collects/mred/private/wx/win32/procs.rkt | 4 +- 2 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 collects/mred/private/wx/win32/colordialog.rkt diff --git a/collects/mred/private/wx/win32/colordialog.rkt b/collects/mred/private/wx/win32/colordialog.rkt new file mode 100644 index 00000000..7147ef38 --- /dev/null +++ b/collects/mred/private/wx/win32/colordialog.rkt @@ -0,0 +1,52 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/string + racket/draw/color + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../../lock.rkt") + +(provide get-color-from-user) + +(define-cstruct _CHOOSECOLOR + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hInstance _HWND] + [rgbResult _COLORREF] + [lpCustColors _pointer] + [Flags _DWORD] + [lCustData _LPARAM] + [lpfnHook _fpointer] + [lpTemplateName _fpointer])) + +(define CC_RGBINIT #x00000001) + +(define-comdlg32 ChooseColorW (_wfun _CHOOSECOLOR-pointer -> _BOOL)) + +(define custom-colors (malloc 'raw 16 _COLORREF)) +(memset custom-colors 255 16 _COLORREF) + +(define (get-color-from-user message parent color) + (atomically + (let ([p (malloc 'raw _CHOOSECOLOR)]) + (memset p 0 1 _CHOOSECOLOR) + (set-cpointer-tag! p CHOOSECOLOR-tag) + (set-CHOOSECOLOR-lStructSize! p (ctype-sizeof _CHOOSECOLOR)) + (when parent + (set-CHOOSECOLOR-hwndOwner! p (send parent get-hwnd))) + (when color + (set-CHOOSECOLOR-rgbResult! p (make-COLORREF + (color-red color) + (color-green color) + (color-blue color))) + (set-CHOOSECOLOR-Flags! p CC_RGBINIT)) + (set-CHOOSECOLOR-lpCustColors! p custom-colors) + (begin0 + (and (ChooseColorW p) + (let ([c (CHOOSECOLOR-rgbResult p)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (free p))))) + diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 0a9e58cb..824169ac 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -14,6 +14,7 @@ (except-in "../common/default-procs.rkt" get-panel-background) "filedialog.rkt" + "colordialog.rkt" racket/draw) (provide @@ -65,8 +66,7 @@ (define-unimplemented write-resource) (define-unimplemented get-resource) -(define-unimplemented get-color-from-user) -(define (color-from-user-platform-mode) #f) +(define (color-from-user-platform-mode) 'dialog) (define (get-panel-background) (let ([c (GetSysColor COLOR_BTNFACE)]) From ef3990468ac1901c63f35f0da7133200d0e8a3c3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 09:41:47 -0600 Subject: [PATCH 290/462] font-dialog clean up and cocoa: play-sound original commit: 46ae5ff086f721f7038c8b97833c68fafeccadd6 --- collects/mred/private/fontdialog.rkt | 2 +- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 7 +++-- collects/mred/private/wx/cocoa/sound.rkt | 35 +++++++++++++++++++++ collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 5 ++- collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 5 ++- 9 files changed, 53 insertions(+), 5 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/sound.rkt diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 5ba477a5..035f1118 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -73,7 +73,7 @@ [(3) 'unsmoothed]) (send sip get-value)))))] [bp (instantiate horizontal-pane% (f) [stretchable-height #f])] - [ms-button (if (eq? (system-type) 'windows) + [ms-button (if (eq? (wx:font-from-user-platform-mode) 'dialog) (begin0 (make-object button% "Use System Dialog..." bp (lambda (b e) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 04bd876f..b53bfef3 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -78,6 +78,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index d0167568..e7f61406 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -16,6 +16,7 @@ "../common/printer.rkt" "menu-bar.rkt" "agl.rkt" + "sound.rkt" "../../lock.rkt" "../common/handlers.rkt" (except-in "../common/default-procs.rkt" @@ -31,6 +32,7 @@ application-pref-handler color-from-user-platform-mode get-color-from-user + font-from-user-platform-mode get-font-from-user get-panel-background play-sound @@ -67,8 +69,6 @@ (import-class NSScreen NSCursor) -(define-unimplemented get-font-from-user) -(define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented send-event) (define-unimplemented write-resource) @@ -76,6 +76,9 @@ (define (color-from-user-platform-mode) "Show Picker") +(define-unimplemented get-font-from-user) +(define (font-from-user-platform-mode) #f) + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) diff --git a/collects/mred/private/wx/cocoa/sound.rkt b/collects/mred/private/wx/cocoa/sound.rkt new file mode 100644 index 00000000..ac0a28ef --- /dev/null +++ b/collects/mred/private/wx/cocoa/sound.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt") + +(provide play-sound) + +(import-class NSSound) + +(define-objc-class MySound NSSound + [result + sema] + [-a _void (sound: [_id sound] didFinishPlaying: [_BOOL ok?]) + (set! result ok?) + (semaphore-post sema) + (tellv self release)]) + +(define (play-sound path async?) + (let ([s (as-objc-allocation + (tell (tell MySound alloc) + initWithContentsOfFile: #:type _NSString (if (path? path) + (path->string path) + path) + byReference: #:type _BOOL #t))] + [sema (make-semaphore)]) + (tellv s setDelegate: s) + (set-ivar! s sema sema) + (tellv s retain) ; don't use `retain', because we dont' want auto-release + (tellv s play) + (if async? + (begin + (semaphore-wait sema) + (get-ivar s result)) + #t))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 712f2f3f..40eef1d4 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -78,6 +78,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index e300a5c4..70d6504f 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -24,6 +24,7 @@ get-color-from-user color-from-user-platform-mode get-font-from-user + font-from-user-platform-mode get-panel-background play-sound find-graphical-system-path @@ -59,7 +60,6 @@ make-gl-bitmap check-for-break) -(define-unimplemented get-font-from-user) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) @@ -71,6 +71,9 @@ (define (color-from-user-platform-mode) 'dialog) +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 4d63680b..5cf54c11 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -63,6 +63,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 9caeea00..167ca364 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -79,6 +79,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 824169ac..ada8bb7e 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -23,6 +23,7 @@ get-color-from-user color-from-user-platform-mode get-font-from-user + font-from-user-platform-mode get-panel-background play-sound find-graphical-system-path @@ -57,7 +58,6 @@ make-gl-bitmap check-for-break) -(define-unimplemented get-font-from-user) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) @@ -68,6 +68,9 @@ (define (color-from-user-platform-mode) 'dialog) +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + (define (get-panel-background) (let ([c (GetSysColor COLOR_BTNFACE)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) From ce98b66906690208676b314e9f7a29245ca42fbc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 09:50:02 -0600 Subject: [PATCH 291/462] win32: play-sound original commit: 3d73a0bd78af6d00e1f59f03aad116a5fe84b044 --- collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/sound.rkt | 20 ++++++++++++++++++++ collects/mred/private/wx/win32/utils.rkt | 3 +++ 3 files changed, 24 insertions(+), 1 deletion(-) create mode 100644 collects/mred/private/wx/win32/sound.rkt diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index ada8bb7e..0aa99636 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -15,6 +15,7 @@ get-panel-background) "filedialog.rkt" "colordialog.rkt" + "sound.rkt" racket/draw) (provide @@ -58,7 +59,6 @@ make-gl-bitmap check-for-break) -(define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) (define-unimplemented send-event) diff --git a/collects/mred/private/wx/win32/sound.rkt b/collects/mred/private/wx/win32/sound.rkt new file mode 100644 index 00000000..02aa963b --- /dev/null +++ b/collects/mred/private/wx/win32/sound.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide play-sound) + +(define-winmm PlaySoundW (_wfun _string/utf-16 _pointer _DWORD -> _BOOL)) + +(define SND_SYNC #x0000) +(define SND_ASYNC #x0001) + +(define (play-sound path async?) + (let ([path (simplify-path path #f)]) + ;; FIXME: sync sound play blocks all Racket threads + (PlaySoundW (if (path? path) (path->string path) path) + #f + (if async? SND_ASYNC SND_SYNC)))) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index afda3e75..7965023d 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,6 +12,7 @@ define-comdlg32 define-shell32 define-uxtheme + define-winmm define-mz failed @@ -49,6 +50,7 @@ (define comdlg32-lib (ffi-lib "comdlg32.dll")) (define shell32-lib (ffi-lib "shell32.dll")) (define uxtheme-lib (ffi-lib "uxtheme.dll")) +(define winmm-lib (ffi-lib "winmm.dll")) (define-ffi-definer define-gdi32 gdi32-lib) (define-ffi-definer define-user32 user32-lib) @@ -57,6 +59,7 @@ (define-ffi-definer define-comdlg32 comdlg32-lib) (define-ffi-definer define-shell32 shell32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) +(define-ffi-definer define-winmm winmm-lib) (define-kernel32 GetLastError (_wfun -> _DWORD)) From 7f2aa8a96b6d1b5707b37a420adca746158c7d8b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 10:38:41 -0600 Subject: [PATCH 292/462] win32: key and menu fixes, drop-files, location->window original commit: f4e74a8f438cc4d9db1ff69899146dbc54194cbd --- collects/mred/private/wx/win32/key.rkt | 2 +- collects/mred/private/wx/win32/menu-bar.rkt | 7 +++- collects/mred/private/wx/win32/menu.rkt | 5 +++ collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/window.rkt | 43 +++++++++++++++++++-- 5 files changed, 51 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 154c65d9..802b7880 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -194,7 +194,7 @@ ;; shift was pressed, so swap role of shifted and unshifted (values s id sa a) (values id s a sa)))) - (values (try-generate-release) #f #f #f)) + (values (and is-up? (try-generate-release)) #f #f #f)) (cond [(and (not is-up?) (= wParam VK_CONTROL)) ;; Don't generate control-key down events: diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 86a389c3..73a07513 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -29,8 +29,11 @@ (send (list-ref menus pos) set-menu-label hmenu pos str) (refresh)) - (def/public-unimplemented number) - (def/public-unimplemented enable-top) + (define/public (number) (length menus)) + + (define/public (enable-top pos on?) + (send (list-ref menus pos) enable-self hmenu pos on?) + (refresh)) (define/public (delete which pos) (atomically diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index db2f8d7a..d11d4fac 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -102,6 +102,11 @@ (bitwise-ior MF_BYPOSITION (if on? MF_ENABLED MF_GRAYED))))))) + (define/public (enable-self parent-hmenu pos on?) + (EnableMenuItem parent-hmenu pos + (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED)))) + (define/public (check id on?) (with-item id diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 0aa99636..be571ada 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -8,6 +8,7 @@ "const.rkt" "menu-item.rkt" "frame.rkt" + "window.rkt" "dc.rkt" "printer-dc.rkt" "../common/printer.rkt" @@ -60,7 +61,6 @@ check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented cancel-quit) (define-unimplemented write-resource) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 72a191dd..cd449ae6 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -20,7 +20,8 @@ (provide window% queue-window-event queue-window-refresh-event - + location->window + GetWindowRect GetClientRect) @@ -54,9 +55,20 @@ (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void)) + +(define _HDROP _pointer) +(define-shell32 DragQueryPoint (_wfun _HDROP (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r p (failed 'DragQueryPoint)))) +(define-shell32 DragQueryFileW (_wfun _HDROP _UINT _pointer _UINT -> _UINT)) +(define-shell32 DragFinish (_wfun _HDROP -> _void)) + (define-user32 SetCapture (_wfun _HWND -> _HWND)) (define-user32 ReleaseCapture (_wfun -> _BOOL)) +(define-user32 WindowFromPoint (_fun _POINT -> _HWND)) +(define-user32 GetParent (_fun _HWND -> _HWND)) + (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -171,6 +183,9 @@ (send wx control-scrolled) 0) (default w msg wParam lParam)))] + [(= msg WM_DROPFILES) + (handle-drop-files wParam) + 0] [else (default w msg wParam lParam)]))) @@ -190,8 +205,6 @@ (unless (memq 'deleted style) (show #t)) - (def/public-unimplemented on-drop-file) - (define/public (on-size w h) (void)) (define/public (on-set-focus) (void)) @@ -331,7 +344,21 @@ (set-box! y (POINT-y p)))) (define/public (drag-accept-files on?) - (void)) + (DragAcceptFiles (get-hwnd) on?)) + + (define/private (handle-drop-files wParam) + (let* ([hdrop (cast wParam _WPARAM _HDROP)] + [pt (DragQueryPoint hdrop)] + [count (DragQueryFileW hdrop #xFFFFFFFF #f 0)]) + (for ([i (in-range count)]) + (let* ([len (DragQueryFileW hdrop i #f 0)] + [b (malloc (add1 len) _int16)]) + (DragQueryFileW hdrop i b (add1 len)) + (let ([s (cast b _pointer _string/utf-16)]) + (queue-window-event this (lambda () (on-drop-file (string->path s))))))) + (DragFinish hdrop))) + + (define/public (on-drop-file p) (void)) (define/public (get-position x y) (set-box! x (get-x)) @@ -601,3 +628,11 @@ (define (queue-window-refresh-event win thunk) (queue-refresh-event (send win get-eventspace) thunk)) + +(define (location->window x y) + (let ([hwnd (WindowFromPoint (make-POINT x y))]) + (let loop ([hwnd hwnd]) + (and hwnd + (or (let ([wx (any-hwnd->wx hwnd)]) + (and wx (send wx get-top-frame))) + (loop (GetParent hwnd))))))) From 5ba5dcead9106e1b4c6738b4950282a747ee75e8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 12:02:46 -0600 Subject: [PATCH 293/462] win32 repairs original commit: 090437c4d98d38bcbbe6ad4255ab539db98371dc --- collects/mred/private/wx/win32/button.rkt | 7 +++++-- collects/mred/private/wx/win32/check-box.rkt | 3 +++ collects/mred/private/wx/win32/item.rkt | 6 +++--- collects/mred/private/wx/win32/queue.rkt | 4 ++-- collects/mred/private/wx/win32/radio-box.rkt | 11 +++++----- collects/mred/private/wx/win32/window.rkt | 21 ++++++++++++-------- collects/mred/private/wxme/editor-canvas.rkt | 3 ++- 7 files changed, 34 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index a8581ac2..e3d86b84 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -54,19 +54,22 @@ [style style]) (when bitmap? - (let ([hbitmap (bitmap->hbitmap label #:bg #xFFFFFF)]) + (let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))]) (remember-label-bitmap hbitmap) (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP (cast hbitmap _HBITMAP _LPARAM)))) (set-control-font font) + (define/public (get-button-background) + #xFFFFFF) + (define/public (auto-size-button label) (cond [bitmap? (auto-size label 0 0 4 4)] [else - (auto-size label 40 12 12 0)])) + (auto-size label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) (auto-size-button label) (subclass-control (get-hwnd)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index ab62b61b..5eae81ad 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -19,6 +19,9 @@ (define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX)) + (define/override (get-button-background) + (GetSysColor COLOR_BTNFACE)) + (define/override (auto-size-button label) (auto-size label 0 0 20 0)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 0ebbc88a..04ba7784 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -79,15 +79,15 @@ (define/override (gets-focus?) #t) ;; Retain to avoid GC of the bitmaps: - (define label-hbitmaps null) + (define label-hbitmap #f) (define/public (remember-label-bitmap hbitmap) - (set! label-hbitmaps (cons hbitmap label-hbitmaps))) + (set! label-hbitmap hbitmap)) (define/public (set-label s) (if (s . is-a? . bitmap%) (let ([hbitmap (bitmap->hbitmap s)]) (atomically - (set! label-hbitmaps (list hbitmap)) + (set! label-hbitmap hbitmap) (SendMessageW (get-hwnd) (get-setimage-message) IMAGE_BITMAP diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index b2960250..ca8e3035 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -69,9 +69,9 @@ (atomically (hash-remove! t id)) (let ([msg (malloc-msg)]) (let loop () - (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) ;; Since we called PeekMeessage in a thread other than the - ;; event-pump thread, see `other-peek-evt' so the pump + ;; event-pump thread, set `other-peek-evt' so the pump ;; knows to check again. (unless (sync/timeout 0 peek-other-peek-evt) (semaphore-post other-peek-evt)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 926f685c..1036d206 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -30,8 +30,7 @@ (inherit auto-size set-control-font is-enabled-to-root? subclass-control - set-focus - remember-label-bitmap) + set-focus) (define callback cb) (define current-value val) @@ -47,6 +46,8 @@ hInstance #f)) + (define label-bitmaps null) + (define radio-hwnds (let loop ([y 0] [w 0] [labels labels]) (if (null? labels) @@ -73,17 +74,17 @@ #f)]) (when bitmap? (let ([hbitmap (bitmap->hbitmap label)]) - (remember-label-bitmap hbitmap) + (set! label-bitmaps (cons hbitmap label-bitmaps)) (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP (cast hbitmap _HBITMAP _LPARAM)))) (ShowWindow radio-hwnd SW_SHOW) (set-control-font font radio-hwnd) - (let-values ([(w h) + (let-values ([(w1 h) (auto-size label 0 0 20 4 (lambda (w h) (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) (values w h)))]) (cons radio-hwnd - (loop (+ y SEP h) (max w h) (cdr labels)))))))) + (loop (+ y SEP h) (max w1 w) (cdr labels)))))))) (unless (= val -1) (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index cd449ae6..88c3a53f 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -79,6 +79,7 @@ (define theme-hfont #f) +#; (define-values (dlu-x dlu-y) (let ([v (GetDialogBaseUnits)]) (values (* 1/4 (bitwise-and v #xFFFF)) @@ -108,7 +109,9 @@ (super-new) - (define eventspace (current-eventspace)) + (define eventspace (if parent + (send parent get-eventspace) + (current-eventspace))) (set-hwnd-wx! hwnd this) (for ([extra-hwnd (in-list extra-hwnds)]) @@ -288,7 +291,9 @@ [resize (lambda (w h) (set-size -11111 -11111 w h))] #:combine-width [combine-w max] - #:combine-height [combine-h max]) + #:combine-height [combine-h max] + #:scale-w [scale-w 1] + #:scale-h [scale-h 1]) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -313,8 +318,8 @@ [else (send measure-dc get-text-extent label #f #t)]))] [(->int) (lambda (v) (inexact->exact (floor v)))]) - (resize (max (->int (+ w dw)) (->int (* dlu-x min-w))) - (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) + (resize (->int (* scale-h (max (+ w dw) min-w))) + (->int (* scale-w (max (+ h dh) min-h)))))) (define/public (popup-menu m x y) (let ([gx (box x)] @@ -431,7 +436,7 @@ (begin (queue-window-event this (lambda () (dispatch-on-char/sync e))) #t) - (constrained-reply (get-eventspace) + (constrained-reply eventspace (lambda () (dispatch-on-char e #t)) #t))) 0 @@ -542,7 +547,7 @@ (begin (queue-window-event this (lambda () (dispatch-on-event/sync e))) #t) - (constrained-reply (get-eventspace) + (constrained-reply eventspace (lambda () (dispatch-on-event e #t)) #t))) @@ -565,7 +570,7 @@ (set! mouse-in? #f) (let ([e (mk 'leave)]) (if (eq? (current-thread) - (eventspace-handler-thread (get-eventspace))) + (eventspace-handler-thread eventspace)) (handle-mouse-event (get-client-hwnd) 0 0 e) (queue-window-event this (lambda () (dispatch-on-event/sync e)))))) @@ -635,4 +640,4 @@ (and hwnd (or (let ([wx (any-hwnd->wx hwnd)]) (and wx (send wx get-top-frame))) - (loop (GetParent hwnd))))))) + (loop (GetParent hwnd))))))) \ No newline at end of file diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index f6c079fe..17017ff9 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -406,7 +406,8 @@ (using-admin (when media (set-custom-cursor - (and (not out-of-client?) + (and (or (not out-of-client?) + (send event dragging?)) (send media adjust-cursor event)))) (when media (send media on-event event)))) From c2bc4a54519bf40c82190de7aac2476a14b04968 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 12:29:48 -0600 Subject: [PATCH 294/462] win32 memory-management repair original commit: 9b19337c971658b3c65c3869d61c691defd2a72e --- collects/mred/private/wx/win32/item.rkt | 20 ++------ collects/mred/private/wx/win32/menu-item.rkt | 7 +-- collects/mred/private/wx/win32/queue.rkt | 3 ++ collects/mred/private/wx/win32/window.rkt | 2 +- collects/mred/private/wx/win32/wndclass.rkt | 49 ++++++++++++++++---- 5 files changed, 53 insertions(+), 28 deletions(-) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 04ba7784..d9a18b8e 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -20,8 +20,9 @@ (if wx (send wx ctlproc w msg wParam lParam (lambda (w msg wParam lParam) - (send wx default-ctlproc w msg wParam lParam))) - (send wx default-ctlproc w msg wParam lParam)))) + ((hwnd->ctlproc w) w msg wParam lParam))) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (default-ctlproc w msg wParam lParam))))) (define control_proc (function-ptr control-proc _WndProc)) @@ -36,14 +37,11 @@ (define/public (command e) (callback this e)) - (define old-control-procs null) - (super-new) (define/public (subclass-control hwnd) (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) - (set! old-control-procs (cons (cons hwnd old-control-proc) - old-control-procs)) + (set-hwnd-ctlproc! hwnd old-control-proc) (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) (define/public (ctlproc w msg wParam lParam default) @@ -60,15 +58,7 @@ (wndproc-for-ctlproc w msg wParam lParam default)]))) (define/public (wndproc-for-ctlproc w msg wParam lParam default) - (wndproc w msg wParam lParam default)) - - (define/public (default-ctlproc w msg wParam lParam) - (let loop ([l old-control-procs]) - (cond - [(null? l) (error 'default-ctlproc "cannot find control in: ~e for: ~e" this w)] - [(ptr-equal? (caar l) w) - ((cdar l) w msg wParam lParam)] - [else (loop (cdr l))]))))) + (wndproc w msg wParam lParam default)))) (define item% (class (item-mixin window%) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 6141375a..c974b6ae 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -4,6 +4,7 @@ "utils.rkt" "types.rkt" "const.rkt" + "../../lock.rkt" "../../syntax.rkt") (provide menu-item% @@ -14,7 +15,7 @@ (define ids (make-hash)) (define (id-to-menu-item id) - (let ([wb (hash-ref ids id #f)]) + (let ([wb (atomically (hash-ref ids id #f))]) (and wb (weak-box-value wb)))) (defclass menu-item% object% @@ -22,12 +23,12 @@ (define id (let loop () (let ([id (add1 (random #x7FFE))]) - (let ([wb (hash-ref ids id #f)]) + (let ([wb (atomically (hash-ref ids id #f))]) (if (and wb (weak-box-value wb)) (loop) (begin - (hash-set! ids id (make-weak-box this)) + (atomically (hash-set! ids id (make-weak-box this))) id)))))) (define parent #f) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index ca8e3035..7fd628d4 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -88,6 +88,7 @@ (free-msg msg)))) (define (queue-message-dequeue es hwnd) + ;; in atomic mode (let ([t (eventspace-extra-table es)] [id (cast hwnd _HWND _long)]) (unless (hash-ref t id #f) @@ -98,6 +99,7 @@ (define msg (malloc-msg)) (define (check-window-event hwnd data) + ;; in atomic mode (let* ([root (let loop ([hwnd hwnd]) (let ([p (GetWindow hwnd GW_OWNER)]) (if p @@ -123,6 +125,7 @@ (define check_window_event (function-ptr check-window-event _enum_proc)) (define (dispatch-all-ready) + ;; in atomic mode (pre-event-sync #f) ;; Windows uses messages above #x4000 to hilite items in the task bar, diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 88c3a53f..f6771c81 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -174,7 +174,7 @@ [cmd (LOWORD (NMHDR-code nmhdr))]) (if (and wx (send wx is-command? cmd)) (begin - (send wx do-command control-hwnd) + (send wx do-command cmd control-hwnd) 0) (default w msg wParam lParam)))] [(or (= msg WM_HSCROLL) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index d789de66..ba0b187e 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -10,31 +10,62 @@ (provide hInstance DefWindowProcW background-hbrush - hwnd->wx - any-hwnd->wx set-hwnd-wx! - unregister-hwnd + set-hwnd-ctlproc! + hwnd->wx + hwnd->ctlproc + any-hwnd->wx + unregister-hwnd MessageBoxW _WndProc) ;; ---------------------------------------- +;; We use the "user data" field of an HWND to +;; store a weak pointer back to the Racket object. +;; The weak pointer must be wrapped in an immuable cell. +;; In addition, if we need to save a control's old +;; ctlproc, we put it in the same immutable cell. +;; So: +;; = (make-immutable-cell ) +;; = +;; | (cons ) +;; = (make-weak-box ) (define all-cells (make-hash)) -(define (hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (ptr-ref p _racket)))) - (define (set-hwnd-wx! hwnd wx) - (let ([c (malloc-immobile-cell wx)]) + (let ([c (malloc-immobile-cell (make-weak-box wx))]) (SetWindowLongW hwnd GWLP_USERDATA c) (atomically (hash-set! all-cells (cast c _pointer _long) #t)))) +(define (set-hwnd-ctlproc! hwnd ctlproc) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc)))) + +(define (hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (and p (let ([wb (ptr-ref p _racket)]) + (and wb + (weak-box-value (if (pair? wb) + (car wb) + wb))))))) + +(define (hwnd->ctlproc hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (and p (let ([wb (ptr-ref p _racket)]) + (and wb + (pair? wb) + (cdr wb)))))) + (define (any-hwnd->wx hwnd) (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (and p (atomically (hash-ref all-cells (cast p _pointer _long) #f)) - (let ([wx (ptr-ref p _racket)]) + (let ([wx (let ([wb (ptr-ref p _racket)]) + (and wb + (weak-box-value (if (pair? wb) + (car wb) + wb))))]) (and wx (send wx is-hwnd? hwnd) wx))))) From 420ba997daadeab5c3097c30429a100da70f1857 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 12:07:17 -0600 Subject: [PATCH 295/462] minor clean-up original commit: 4d8497b985c88fae21dab44c1f32e2afa1808fe4 --- collects/mred/private/wx/gtk/procs.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 70d6504f..7dc0d0ea 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -36,7 +36,6 @@ file-creator-and-type run-printout get-double-click-time - key-symbol-to-integer get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -60,15 +59,15 @@ make-gl-bitmap check-for-break) -(define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) (define-unimplemented send-event) -(define-unimplemented key-symbol-to-integer) (define-unimplemented cancel-quit) (define-unimplemented write-resource) (define-unimplemented get-resource) +(define-unimplemented play-sound) + (define (color-from-user-platform-mode) 'dialog) (define (font-from-user-platform-mode) #f) From 1d77e383b0d4e1dbf948784aa1677e688839383d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 12:39:11 -0600 Subject: [PATCH 296/462] gtk menu-bar fixes original commit: c57c84721fd1c43e8153c22f30fdd0c4539d965b --- collects/mred/private/wx/gtk/menu-bar.rkt | 26 ++++++++++++----------- 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 4771e446..de8824c4 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -114,20 +114,22 @@ (gtk_label_set_text_with_mnemonic (gtk_bin_get_child item-gtk) (fixup-mneumonic str))))) - (def/public-unimplemented enable-top) + (define/public (enable-top pos on?) + (gtk_widget_set_sensitive (car (list-ref menus pos)) on?)) (define/public (delete which pos) - (set! menus (let loop ([menus menus] - [pos pos]) - (cond - [(null? menus) menus] - [(zero? pos) - (gtk_container_remove gtk (caar menus)) - (gtk_menu_item_set_submenu (caar menus) #f) - (cdr menus)] - [else (cons (car menus) - (loop (cdr menus) - pos))])))) + (atomically + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) + (gtk_container_remove gtk (caar menus)) + (gtk_menu_item_set_submenu (caar menus) #f) + (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + (sub1 pos)))]))))) (public [append-menu append]) (define (append-menu menu title) From 30b2c4d867ddc6393b182936a48f9e43e10c4995 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 13:25:53 -0600 Subject: [PATCH 297/462] gtk: make gl support optional and also clean up some unneeded unimplementeds original commit: 27f18efa881c411614657a3ed93db51c0b2ac357 --- collects/mred/private/wx/cocoa/canvas.rkt | 2 -- collects/mred/private/wx/cocoa/frame.rkt | 8 ++------ collects/mred/private/wx/cocoa/panel.rkt | 4 +--- collects/mred/private/wx/cocoa/window.rkt | 11 +++-------- collects/mred/private/wx/gtk/canvas.rkt | 2 -- collects/mred/private/wx/gtk/frame.rkt | 14 +++++++++----- collects/mred/private/wx/gtk/gl-context.rkt | 16 ++++++++++------ collects/mred/private/wx/gtk/menu.rkt | 3 ++- collects/mred/private/wx/gtk/panel.rkt | 4 +--- collects/mred/private/wx/gtk/window.rkt | 10 ++-------- collects/mred/private/wx/win32/canvas.rkt | 2 -- collects/mred/private/wx/win32/frame.rkt | 3 +-- collects/mred/private/wx/win32/panel.rkt | 4 +--- collects/mred/private/wx/win32/window.rkt | 7 ------- collects/mred/private/wxme/editor-canvas.rkt | 6 ++++-- collects/mred/private/wxpanel.rkt | 8 +------- 16 files changed, 37 insertions(+), 67 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index dabf6444..2e50cc5c 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -691,8 +691,6 @@ ;; Called in Cocoa event-handling mode in-menu-click?) - (def/public-unimplemented set-background-to-gray) - (define/public (scroll x y) (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7daf05d9..6f91dd18 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -468,9 +468,9 @@ (define/public (on-menu-click) (void)) (define/public (on-toolbar-click) (void)) - (def/public-unimplemented on-menu-command) + (define/public (on-menu-command c) (void)) (def/public-unimplemented on-mdi-activate) - (def/public-unimplemented on-close) + (define/public (on-close) #t) (define/public (designate-root-frame) (set! root-fake-frame this)) (def/public-unimplemented system-menu) @@ -479,10 +479,6 @@ (let ([b (tell cocoa standardWindowButton: #:type _NSInteger NSWindowCloseButton)]) (tellv b setDocumentEdited: #:type _BOOL on?))) - (define/public (create-status-line) (void)) - (define/public (set-status-text s) (void)) - (def/public-unimplemented status-line-exists?) - (define/public (is-maximized?) (tell #:type _BOOL cocoa isZoomed)) (define/public (maximize on?) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index aad8308a..46047d2c 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -70,9 +70,7 @@ (super show on?) (fix-dc)) - (def/public-unimplemented on-paint) - (define/public (set-item-cursor x y) (void)) - (def/public-unimplemented get-item-cursor))) + (define/public (set-item-cursor x y) (void)))) (defclass panel% (panel-mixin window%) (init parent diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 6a04a6e9..3ff8328f 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -643,8 +643,7 @@ (set! sticky-cursor? #f) (send (get-parent) end-no-cursor-rects)) - (def/public-unimplemented get-handle) - (def/public-unimplemented set-phantom-size) + (define/public (get-handle) (get-cocoa)) (define/public (popup-menu m x y) (send m do-popup (get-cocoa-content) x (flip-client y) @@ -652,7 +651,7 @@ (queue-window-event this thunk)))) (define/public (center a b) (void)) - (def/public-unimplemented refresh) + (define/public (refresh) (void)) (define/public (screen-to-client xb yb) (let ([p (tell #:type _NSPoint (get-cocoa-content) @@ -677,8 +676,6 @@ (set-box! xb (inexact->exact (floor (NSPoint-x p)))) (set-box! yb (inexact->exact (floor new-y)))))) - (def/public-unimplemented fit) - (define cursor-handle #f) (define sticky-cursor? #f) (define/public (set-cursor c) @@ -707,9 +704,7 @@ (define/public (can-be-responder?) #t) (define/public (on-color-change) - (send parent on-color-change)) - - (def/public-unimplemented centre))) + (send parent on-color-change)))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index e41491ad..52a94297 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -525,8 +525,6 @@ (define/public (set-combo-text t) (void)) - (def/public-unimplemented set-background-to-gray) - (define/public (do-scroll direction) (if (is-auto-scroll?) (refresh-for-autoscroll) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 74153f86..8b1522cf 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -183,7 +183,7 @@ (gtk_fixed_move panel-gtk child-gtk x y) (gtk_widget_set_size_request child-gtk w h)) - (define/public (on-close) (void)) + (define/public (on-close) #t) (define/public (set-menu-bar mb) (let ([mb-gtk (send mb get-gtk)]) @@ -357,11 +357,15 @@ (set-box! x (+ (unbox x) dx cdx)) (set-box! y (+ (unbox y) dy cdy)))) - (def/public-unimplemented on-toolbar-click) - (def/public-unimplemented on-menu-click) - (def/public-unimplemented on-menu-command) + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-click) (void)) + + (define/public (on-menu-command c) (void)) + (def/public-unimplemented on-mdi-activate) - (def/public-unimplemented on-activate) + + (define/public (on-activate on?) (void)) + (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index f4c213eb..7f0aae79 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -16,9 +16,11 @@ install-gl-context) (define gdkglext-lib - (ffi-lib "libgdkglext-x11-1.0" '("0"))) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libgdkglext-x11-1.0" '("0")))) (define gtkglext-lib - (ffi-lib "libgtkglext-x11-1.0" '("0"))) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libgtkglext-x11-1.0" '("0")))) (define-ffi-definer define-gdkglext gdkglext-lib #:default-make-fail make-not-available) @@ -34,9 +36,10 @@ (define-gdkglext gdk_gl_init (_fun (_ptr i _int) (_ptr i _pointer) -> _void) - #:fail void) + #:fail (lambda () void)) -(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig))) +(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig)) + #:fail (lambda () (lambda args #f))) (define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig))) (define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) @@ -47,9 +50,10 @@ _gboolean _int -> _gboolean) - #:fail (lambda args #f)) + #:fail (lambda () (lambda args #f))) -(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext)) +(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext) + #:fail (lambda () (lambda args #f))) (define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable)) (define-gdkglext gdk_gl_context_destroy (_fun _GdkGLContext -> _void) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 68d59b21..f7f4f973 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -219,7 +219,8 @@ (def/public-unimplemented set-title) (def/public-unimplemented set-help-string) - (def/public-unimplemented number) + + (define/public (number) (length items)) (define/private (find-gtk item) (for/or ([i items]) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 4947b465..e485751f 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -49,9 +49,7 @@ (cons child children) (remq child children)))))) - (def/public-unimplemented on-paint) - (define/public (set-item-cursor x y) (void)) - (def/public-unimplemented get-item-cursor))) + (define/public (set-item-cursor x y) (void)))) (define panel% (class (panel-mixin window%) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 36ef33f2..855fbc2c 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -611,8 +611,7 @@ (define/public (on-drop-file path) (void)) - (def/public-unimplemented get-handle) - (def/public-unimplemented set-phantom-size) + (define/public (get-handle) (get-gtk)) (define/public (popup-menu m x y) (let ([gx (box x)] @@ -639,12 +638,7 @@ (define/public (get-client-delta) (values 0 0)) - (def/public-unimplemented get-position) - (def/public-unimplemented fit) - - (define/public (gets-focus?) #t) - - (def/public-unimplemented centre))) + (define/public (gets-focus?) #t))) (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index a5aabf12..a681d2f9 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -330,8 +330,6 @@ (define/override (get-virtual-v-pos) (GetScrollPos canvas-hwnd SB_VERT)) - (def/public-unimplemented set-background-to-gray) - (define/public (get-scroll-pos which) (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) (define/public (get-scroll-range which) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 8bc64a74..bb2e852a 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -92,7 +92,6 @@ get-eventspace on-size get-size - get-position pre-on-char pre-on-event reset-cursor-in-child) @@ -226,7 +225,7 @@ (maximize #f)) (super set-size x y w h)) - (define/public (on-close) (void)) + (define/public (on-close) #t) (define/override (is-shown-to-root?) (is-shown?)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 1a3ffbd5..1ed5ddd6 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -73,9 +73,7 @@ (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) - (def/public-unimplemented on-paint) - (define/public (set-item-cursor x y) (void)) - (def/public-unimplemented get-item-cursor))) + (define/public (set-item-cursor x y) (void)))) (define panel% (class (panel-mixin window%) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index f6771c81..2de9e475 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -245,8 +245,6 @@ (define/public (is-shown?) shown?) - (def/public-unimplemented set-phantom-size) - (define/public (paint-children) (void)) (define/public (get-x) @@ -365,10 +363,6 @@ (define/public (on-drop-file p) (void)) - (define/public (get-position x y) - (set-box! x (get-x)) - (set-box! y (get-y))) - (define/public (get-client-size w h) (let ([r (GetClientRect (get-client-hwnd))]) (set-box! w (- (RECT-right r) (RECT-left r))) @@ -418,7 +412,6 @@ (send parent not-focus-child v)) (define/public (gets-focus?) #f) - (def/public-unimplemented centre) (define/public (register-child child on?) (void)) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index 17017ff9..55542210 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -808,8 +808,10 @@ (values 0 0 0 0 1 1) (when (not media) (let ([dc (get-dc)]) - (send dc set-background (get-canvas-background)) - (send dc clear)))))]) + (let ([bg (get-canvas-background)]) + (when bg + (send dc set-background bg) + (send dc clear)))))))]) (if (not (and (= scroll-width hnum-scrolls) (= scroll-height vnum-scrolls) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index 74f7b396..29bd3e8c 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -419,14 +419,8 @@ (raise-mismatch-error 'container-redraw "result from place-children is not a list of 4-integer lists with the correct length: " l)) - (when hidden-child - ;; This goes with the hack for macos and macosx below - (send hidden-child set-phantom-size width height)) (panel-redraw children children-info (if hidden-child - (cons (list 0 0 width - (if (memq (system-type) '(macos macosx)) ;; Yucky hack - (child-info-y-min (car children-info)) - height)) + (cons (list 0 0 width height) (let ([dy (child-info-y-min (car children-info))]) (map (lambda (i) (list (+ (car i) tab-h-border) From 2e30a7dc7c61e91faf81e13cd68542782f75e62b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 14:24:48 -0600 Subject: [PATCH 298/462] gtk: misc fixes original commit: 16b34c236a143c7fb3065db28e1b52f1c6012ed2 --- collects/mred/private/wx/common/queue.rkt | 1 + collects/mred/private/wx/gtk/frame.rkt | 37 +++++++++++++++++-- collects/mred/private/wx/gtk/procs.rkt | 10 +---- collects/mred/private/wx/gtk/types.rkt | 1 + collects/mred/private/wx/gtk/window.rkt | 1 + collects/mred/private/wx/win32/frame.rkt | 6 +-- collects/mred/private/wx/win32/window.rkt | 2 +- .../scribblings/gui/mouse-event-class.scrbl | 4 +- collects/tests/gracket/{mem.rktl => mem.rkt} | 16 ++++---- 9 files changed, 51 insertions(+), 27 deletions(-) rename collects/tests/gracket/{mem.rktl => mem.rkt} (96%) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e99d411a..1383e842 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -190,6 +190,7 @@ -> _pointer)) (define (shutdown-eventspace! e ignored) + ;; atomic mode (unless (eventspace-shutdown? e) (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8b1522cf..061e3b41 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -13,12 +13,14 @@ "window.rkt" "client-window.rkt" "widget.rkt" - "procs.rkt" "cursor.rkt" "pixbuf.rkt" "../common/queue.rkt") -(provide frame%) +(provide frame% + display-origin + display-size + location->window) ;; ---------------------------------------- @@ -121,6 +123,9 @@ (for/fold ([l #f]) ([i (in-list icons)]) (g_list_insert l i -1)))))) +;; used for location->window +(define all-frames (make-hasheq)) + (define frame% (class (client-size-mixin window%) (init parent @@ -296,10 +301,15 @@ (void)) (define/override (direct-show on?) + ;; atomic mode + (if on? + (hash-set! all-frames this #t) + (hash-remove! all-frames this)) (super direct-show on?) (register-frame-shown this on?)) (define/public (destroy) + ;; atomic mode (direct-show #f)) (define/override (on-client-size w h) @@ -366,7 +376,8 @@ (define/public (on-activate on?) (void)) - (def/public-unimplemented designate-root-frame) + (define/public (designate-root-frame) (void)) + (def/public-unimplemented system-menu) (define/public (set-modified mod?) @@ -421,3 +432,23 @@ (string-append s "*") s))))) +;; ---------------------------------------- + +(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) +(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) + +(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) +(define (display-size w h all?) + (let ([s (gdk_screen_get_default)]) + (set-box! w (gdk_screen_get_width s)) + (set-box! h (gdk_screen_get_height s)))) + +(define (location->window x y) + (for/or ([f (in-hash-keys all-frames)]) + (let ([fx (send f get-x)] + [fw (send f get-width)]) + (and (<= fx x (+ fx fw)) + (let ([fy (send f get-y)] + [fh (send f get-height)]) + (<= fy y (+ fy fh))) + f)))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 7dc0d0ea..294ec927 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -11,6 +11,7 @@ "style.rkt" "widget.rkt" "window.rkt" + "frame.rkt" "dc.rkt" "printer-dc.rkt" "gl-context.rkt" @@ -60,7 +61,6 @@ check-for-break) (define-unimplemented find-graphical-system-path) -(define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented cancel-quit) (define-unimplemented write-resource) @@ -85,14 +85,6 @@ (define (get-control-font-size) 10) ;; FIXME (define (get-control-font-size-in-pixels?) #f) ;; FIXME -(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) -(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) - -(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) -(define (display-size w h all?) - (let ([s (gdk_screen_get_default)]) - (set-box! w (gdk_screen_get_width s)) - (set-box! h (gdk_screen_get_height s)))) (define (get-display-depth) 32) (define-gdk gdk_display_beep (_fun _GdkDisplay -> _void)) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 8bb4f761..7d2fd03a 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -104,6 +104,7 @@ (define-cstruct _GdkEventCrossing ([type _GdkEventType] [window _GdkWindow] [send_event _byte] + [subwindow _GdkWindow] [time _uint32] [x _double] [y _double] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 855fbc2c..f68f784a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -478,6 +478,7 @@ (define shown? #f) (define/public (direct-show on?) + ;; atomic mode (if on? (gtk_widget_show gtk) (gtk_widget_hide gtk)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index bb2e852a..76c9fc11 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -237,8 +237,8 @@ (define/override (get-y) (RECT-top (GetWindowRect hwnd))) - (def/public-unimplemented on-toolbar-click) - (def/public-unimplemented on-menu-click) + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-click) (void)) (define/public (on-menu-command i) (void)) @@ -348,7 +348,7 @@ (define/override (get-top-frame) this) - (def/public-unimplemented designate-root-frame) + (define/public (designate-root-frame) (void)) (def/public-unimplemented system-menu) (define modified? #f) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 2de9e475..eea9ba42 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -327,7 +327,7 @@ hwnd (lambda (thunk) (queue-window-event this thunk))))) - (def/public-unimplemented center) + (define/public (center a b) (void)) (define/public (get-parent) parent) (define/public (is-frame?) #f) diff --git a/collects/scribblings/gui/mouse-event-class.scrbl b/collects/scribblings/gui/mouse-event-class.scrbl index 4ba715b8..9c9d2129 100644 --- a/collects/scribblings/gui/mouse-event-class.scrbl +++ b/collects/scribblings/gui/mouse-event-class.scrbl @@ -148,7 +148,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button Returns the type of the event; see @scheme[mouse-event%] for information about each event type. See also @method[mouse-event% -set-event-type] . +set-event-type]. } @@ -260,7 +260,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button void?]{ Sets the type of the event; see @scheme[mouse-event%] for information -about each event type. See also @method[mouse-event% get-event-type] . +about each event type. See also @method[mouse-event% get-event-type]. } diff --git a/collects/tests/gracket/mem.rktl b/collects/tests/gracket/mem.rkt similarity index 96% rename from collects/tests/gracket/mem.rktl rename to collects/tests/gracket/mem.rkt index 9255637d..7e3603ee 100644 --- a/collects/tests/gracket/mem.rktl +++ b/collects/tests/gracket/mem.rkt @@ -1,5 +1,4 @@ - -; run with gracket -u -- -f mem.rktl +#lang racket/gui (require mzlib/class100) @@ -28,13 +27,12 @@ allocated)) v) -(when subwindows? - (namespace-set-variable-value! - 'sub-collect-frame - (make-object frame% "sub-collect")) - (namespace-set-variable-value! - 'sub-collect-panel - (make-object panel% sub-collect-frame))) +(define sub-collect-frame + (and subwindows? + (make-object frame% "sub-collect"))) +(define sub-collect-panel + (and subwindows? + (make-object panel% sub-collect-frame))) (define permanent-ready? #f) (define mb-lock (make-semaphore 1)) From 790d5d1f016b5cab9d8f49645827b94955bde532 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2010 07:59:54 -0600 Subject: [PATCH 299/462] cocoa: avoid 10.6-specific NSImage method original commit: cdecd363593cb4128a290f3b4b4cf74af25c13c2 --- collects/mred/private/wx/cocoa/image.rkt | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index 07f2d1d8..ba1251db 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -6,17 +6,20 @@ "utils.rkt" "types.rkt" "const.rkt" + "cg.rkt" "../../lock.rkt" (only-in '#%foreign ffi-callback)) (provide bitmap->image) -(import-class NSImage) +(import-class NSImage NSGraphicsContext) (define _CGImageRef (_cpointer 'CGImageRef)) (define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef)) (define _CGDataProviderRef (_cpointer 'GCDataProviderRef)) +(define _CGRect _NSRect) + (define _size_t _long) (define _off_t _long) @@ -36,6 +39,8 @@ _int ; intent -> _CGImageRef)) +(define-appserv CGContextDrawImage (_fun _CGContextRef _CGRect _CGImageRef -> _void)) + (define free-it (ffi-callback free (list _pointer) _void #f #t)) @@ -79,7 +84,22 @@ 0)]) (CGDataProviderRelease provider) (CGColorSpaceRelease cs) + ;; This works on 10.6 and later: + #; (as-objc-allocation (tell (tell NSImage alloc) initWithCGImage: #:type _CGImageRef image - size: #:type _NSSize (make-NSSize w h)))))))) + size: #:type _NSSize (make-NSSize w h))) + ;; To work with older versions: + (let* ([size (make-NSSize w h)] + [i (as-objc-allocation + (tell (tell NSImage alloc) + initWithSize: #:type _NSSize size))]) + (tellv i lockFocus) + (CGContextDrawImage + (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort) + (make-NSRect (make-NSPoint 0 0) size) + image) + (tellv i unlockFocus) + i)))))) + From dca0bd73859e1f6018ba3af508c6c2a28bd1c7f0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2010 10:22:46 -0600 Subject: [PATCH 300/462] gtk: fix memory management for menus original commit: 3f28042517322ea4a7120e37e7a77c24a3d059f2 --- collects/mred/private/wx/gtk/menu-bar.rkt | 4 +++- collects/mred/private/wx/gtk/menu.rkt | 14 ++++++++------ 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index de8824c4..ce1e887f 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -135,7 +135,9 @@ (define (append-menu menu title) (send menu set-parent this) (atomically - (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] + (let* ([item (let ([title (fixup-mneumonic title)]) + (as-gtk-allocation + (gtk_menu_item_new_with_mnemonic title)))] [item-wx (new top-menu% [parent this] [gtk item])]) (connect-select item) (set! menus (append menus (list (list item menu item-wx)))) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index f7f4f973..42cd4e07 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -182,11 +182,13 @@ (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) (atomically - (let ([item-gtk ((if (and chckable? - (not (help-str-or-submenu . is-a? . menu%))) - gtk_check_menu_item_new_with_mnemonic - gtk_menu_item_new_with_mnemonic) - (fixup-mneumonic label))]) + (let ([item-gtk (let ([label (fixup-mneumonic label)]) + (as-gtk-allocation + ((if (and chckable? + (not (help-str-or-submenu . is-a? . menu%))) + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + label)))]) (if (help-str-or-submenu . is-a? . menu%) (let ([submenu help-str-or-submenu]) (let ([gtk (send submenu get-gtk)]) @@ -208,7 +210,7 @@ (define/public (append-separator) (atomically - (let ([item-gtk (gtk_separator_menu_item_new)]) + (let ([item-gtk (as-gtk-allocation (gtk_separator_menu_item_new))]) (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk)))) From 7874ecadb60b0233983228a56c925fedad3db821 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2010 20:31:01 -0600 Subject: [PATCH 301/462] avoid redundant on-subwindow-X calls due to panels in a frame original commit: cafc6d697e479ed6b273a1d52e46932b9341b547 --- collects/mred/private/mrtop.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index f4153ebc..c107cfb1 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -122,8 +122,10 @@ [finish (entry-point (lambda (top-level hide-panel?) (set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (send mid-panel skip-subwindow-events? #t) (send (send mid-panel area-parent) add-child mid-panel) (set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f)) + (send wx-panel skip-subwindow-events? #t) (send (send wx-panel area-parent) add-child wx-panel) (send top-level set-container wx-panel) (when hide-panel? From 1c7356515db8c75067ceabd91f1f06b0d8fa9ea8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 Oct 2010 12:01:53 -0600 Subject: [PATCH 302/462] gtk: command line and single-instance support original commit: 045da06ace116be7a2da466d6565b885cb006be1 --- collects/mred/private/wx/common/queue.rkt | 4 +- collects/mred/private/wx/gtk/init.rkt | 3 - collects/mred/private/wx/gtk/queue.rkt | 62 ++++++++++++++-- collects/mred/private/wx/gtk/unique.rkt | 86 +++++++++++++++++++++++ 4 files changed, 147 insertions(+), 8 deletions(-) create mode 100644 collects/mred/private/wx/gtk/unique.rkt diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 1383e842..5f717ea3 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -50,7 +50,9 @@ begin-busy-cursor end-busy-cursor - is-busy?) + is-busy? + + scheme_register_process_global) ;; ------------------------------------------------------------ ;; This module must be instantiated only once: diff --git a/collects/mred/private/wx/gtk/init.rkt b/collects/mred/private/wx/gtk/init.rkt index 190be27f..ba601aeb 100644 --- a/collects/mred/private/wx/gtk/init.rkt +++ b/collects/mred/private/wx/gtk/init.rkt @@ -5,8 +5,6 @@ "queue.rkt") (unsafe!) -(define-gtk gtk_init (_fun (_ptr io _int) (_ptr io _pointer) -> _void)) - (define-gtk gtk_rc_parse_string (_fun _string -> _void)) (define-gtk gtk_rc_add_default_file (_fun _path -> _void)) (define-gtk gtk_rc_find_module_in_path (_fun _path -> _path)) @@ -17,6 +15,5 @@ (gtk_rc_parse_string (format "module_path \"~a\"\n" dir)) (gtk_rc_add_default_file (build-path dir "gtkrc")))) -(gtk_init 0 #f) (define pump-thread (gtk-start-event-pump)) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 332c7c3d..a8c41134 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -7,7 +7,8 @@ "../common/queue.rkt" "../common/freeze.rkt" "const.rkt" - "w32.rkt") + "w32.rkt" + "unique.rkt") (provide gtk-start-event-pump @@ -20,12 +21,65 @@ queue-event yield) + +;; ------------------------------------------------------------ +;; Gtk initialization + +(define-gtk gtk_init_check (_fun (_ptr io _int) (_ptr io _gcpointer) -> _gboolean)) + +(let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)] + [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)] + [argv (and (positive? argc) + (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))] + [display (getenv "DISPLAY")]) + ;; Convert X11 arguments, if any, to Gtk form: + (let-values ([(args single-instance?) + (if (zero? argc) + (values null #f) + (let loop ([i 1][si? #f]) + (if (= i argc) + (values null si?) + (let ([s (ptr-ref argv _bytes i)]) + (cond + [(bytes=? s #"-display") + (let-values ([(args si?) (loop (+ i 2) si?)] + [(d) (ptr-ref argv _bytes (add1 i))]) + (set! display (bytes->string/utf-8 d #\?)) + (values (list* #"--display" d args) + si?))] + [(bytes=? s #"-synchronous") + (let-values ([(args si?) (loop (+ i 1) si?)]) + (values (cons #"--sync" args) + si?))] + [(bytes=? s #"-singleInstance") + (loop (add1 i) #t)] + [(or (bytes=? s #"-iconic") + (bytes=? s #"-rv") + (bytes=? s #"+rv") + (bytes=? s #"-reverse")) + ;; ignored with 0 arguments + (loop (add1 i) #t)] + [else + ;; all other ignored flags have a single argument + (loop (+ i 2) #t)])))))]) + (let-values ([(new-argc new-argv) + (if (null? args) + (values 0 #f) + (values (add1 (length args)) + (cast (cons (ptr-ref argv _bytes 0) + args) + (_list i _bytes) + _pointer)))]) + (unless (gtk_init_check new-argc new-argv) + (error (format + "Gtk initialization failed for display ~s" + (or display ":0")))) + (when single-instance? + (do-single-instance))))) + ;; ------------------------------------------------------------ ;; Gtk event pump -(define-gtk gtk_init (_fun _int _pointer -> _void)) -(gtk_init 0 #f) - (define-gtk gtk_events_pending (_fun -> _gboolean)) (define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) diff --git a/collects/mred/private/wx/gtk/unique.rkt b/collects/mred/private/wx/gtk/unique.rkt new file mode 100644 index 00000000..9ab6255d --- /dev/null +++ b/collects/mred/private/wx/gtk/unique.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + racket/draw/bstr + net/base64 + "types.rkt" + "utils.rkt") + +(provide do-single-instance) + +(define unique-lib + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libunique-1.0" '("0")))) + +(define-ffi-definer define-unique unique-lib + #:default-make-fail make-not-available) + +(define _gsize _ulong) + +(define UNIQUE_RESPONSE_OK 1) + +(define _UniqueApp _GtkWidget) ; not a widget, but we want to connect a signal +(define _UniqueMessageData (_cpointer 'UniqueMessageData)) + +(define-unique unique_app_new (_fun _string _string -> _UniqueApp) + #:fail (lambda () (lambda args #f))) +(define-unique unique_app_add_command (_fun _UniqueApp _string _int -> _void)) +(define-unique unique_app_is_running (_fun _UniqueApp -> _gboolean)) +(define-unique unique_app_send_message (_fun _UniqueApp _int _UniqueMessageData -> _int)) + +(define-unique unique_message_data_new (_fun -> _UniqueMessageData)) +(define-unique unique_message_data_free (_fun _UniqueMessageData -> _void)) +(define-unique unique_message_data_set (_fun _UniqueMessageData _pointer _gsize -> _void)) +(define-unique unique_message_data_get (_fun _UniqueMessageData (len : (_ptr o _gsize)) + -> (data : _bytes) + -> (scheme_make_sized_byte_string + data + len + 0))) + +(define-signal-handler connect-message-received "message-received" + (_fun _UniqueApp _int _UniqueMessageData _uint -> _int) + (lambda (app cmd data time) + UNIQUE_RESPONSE_OK)) + +(define-mz gethostname (_fun _pointer _long -> _int) + #:fail (lambda () #f)) + +(define HOSTLEN 256) + +(define (build-app-name) + (let-values ([(path) (simplify-path + (path->complete-path + (or (find-executable-path (find-system-path 'run-file) #f) + (find-system-path 'run-file)) + (current-directory)))] + [(host) (or (and gethostname + (let ([b (make-bytes HOSTLEN)]) + (and (zero? (gethostname b HOSTLEN)) + (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" b)) #\?)))) + "")]) + (string->bytes/utf-8 + (format "org.racket-lang.~a" + (encode + (format "~a~a~a" host path (version))))))) + +(define (encode s) + (regexp-replace* #rx"\r\n" (base64-encode (string->bytes/utf-8 s)) "")) + +(define (send-command-line app) + (let ([msg (unique_message_data_new)] + [b (let ([o (open-output-bytes)]) + (write (current-command-line-arguments) o) + (get-output-bytes o))]) + (unique_message_data_set msg b (bytes-length b)) + (unique_app_send_message app 42 msg))) + +(define (do-single-instance) + (let ([app (unique_app_new (build-app-name) #f)]) + (when app + (unique_app_add_command app "startup" 42) + (when (unique_app_is_running app) + (when (= (send-command-line app) + UNIQUE_RESPONSE_OK) + (exit 0))) + (connect-message-received app)))) From ef52659ef2de48cedaf518a77fb73ca4a0bf279d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 Oct 2010 15:19:00 -0600 Subject: [PATCH 303/462] win32: single-instance support original commit: 4360a45fa6ee0a42656c61fd294be9b878fbc002 --- collects/mred/private/wx/win32/window.rkt | 64 +++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index eea9ba42..ab0a7428 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe racket/class racket/draw + racket/draw/bstr "../../syntax.rkt" "../common/freeze.rkt" "../common/queue.rkt" @@ -102,6 +103,17 @@ (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) +(define WM_IS_GRACKET (cast (scheme_register_process_global "PLT_WM_IS_GRACKET" #f) + _pointer + _UINT_PTR)) +(define GRACKET_GUID (cast (scheme_register_process_global "PLT_GRACKET_GUID" #f) + _pointer + _bytes)) +(define-cstruct _COPYDATASTRUCT + ([dwData _pointer] + [cbData _DWORD] + [lpData _pointer])) + (defclass window% object% (init-field parent hwnd) (init style @@ -189,6 +201,15 @@ [(= msg WM_DROPFILES) (handle-drop-files wParam) 0] + ;; for single-instance applications: + [(and (= msg WM_IS_GRACKET) + (positive? WM_IS_GRACKET)) + ;; return 79 to indicate that this is a GRacket window + 79] + ;; also for single-instance: + [(= msg WM_COPYDATA) + (handle-copydata lParam) + 0] [else (default w msg wParam lParam)]))) @@ -621,6 +642,49 @@ ;; ---------------------------------------- +(define (handle-copydata lParam) + (let* ([cd (cast lParam _LPARAM _COPYDATASTRUCT-pointer)] + [data (COPYDATASTRUCT-lpData cd)] + [guid-len (bytes-length GRACKET_GUID)] + [data-len (COPYDATASTRUCT-cbData cd)]) + (when (and (data-len + . > . + (+ guid-len (ctype-sizeof _DWORD))) + (bytes=? GRACKET_GUID + (scheme_make_sized_byte_string data + guid-len + 0)) + (bytes=? #"OPEN" + (scheme_make_sized_byte_string (ptr-add data guid-len) + 4 + 0))) + ;; The command line's argv (sans argv[0]) is + ;; expressed as a DWORD for the number of args, + ;; followed by each arg. Each arg is a DWORD + ;; for the number of chars and then the chars + (let ([args + (let ([count (ptr-ref data _DWORD 'abs (+ guid-len 4))]) + (let loop ([i 0] [delta (+ guid-len 4 (ctype-sizeof _DWORD))]) + (if (or (= i count) + ((+ delta (ctype-sizeof _DWORD)) . > . data-len)) + null + (let ([len (ptr-ref (ptr-add data delta) _DWORD)] + [delta (+ delta (ctype-sizeof _DWORD))]) + (if ((+ delta len) . > . data-len) + null + (let ([s (scheme_make_sized_byte_string + (ptr-add data delta) + len + 1)]) + (if (or (bytes=? s #"") + (regexp-match? #rx"\0" s)) + null + (cons (bytes->path s) + (loop (add1 i) (+ delta len))))))))))]) + (map queue-file-event args))))) + +;; ---------------------------------------- + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) From 45ef0beadd060f45dea333a0c191bfaed96a8dac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 Oct 2010 21:00:50 -0700 Subject: [PATCH 304/462] avoid 10.6-only print-scaling methods original commit: 0521f20f2639288d926594abb242a5aed1e71cd1 --- collects/mred/private/wx/cocoa/printer-dc.rkt | 36 +++++++++++++++---- 1 file changed, 29 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index 854a5f27..b48d2f04 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -10,6 +10,7 @@ racket/draw/ps-setup ffi/unsafe ffi/unsafe/objc + "../../lock.rkt" "dc.rkt" "cg.rkt" "utils.rkt" @@ -19,11 +20,14 @@ show-print-setup) (import-class NSPrintOperation NSView NSGraphicsContext - NSPrintInfo NSDictionary NSPageLayout) + NSPrintInfo NSDictionary NSPageLayout + NSNumber) (define NSPortraitOrientation 0) (define NSLandscapeOrientation 1) +(define-cocoa NSPrintScalingFactor _id) + (define-objc-class PrinterView NSView [wxb] [-a _BOOL (knowsPageRange: [_NSRange-pointer rng]) @@ -57,15 +61,33 @@ (tell prev dictionary) (tell NSDictionary dictionary))))) +(define (get-scaling-factor print-info) + ;; 10.6 only: + #; + (tell #:type _CGFloat print-info scalingFactor) + (atomically + (with-autorelease + (tell #:type _double + (tell (tell print-info dictionary) + objectForKey: NSPrintScalingFactor) + doubleValue)))) (define (install-pss-to-print-info pss print-info) (tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape) NSLandscapeOrientation NSPortraitOrientation)) - (tellv print-info setScalingFactor: #:type _CGFloat (let ([x (box 0)] - [y (box 0)]) - (send pss get-scaling x y) - (unbox y)))) + (let ([scale (let ([x (box 0)] + [y (box 0)]) + (send pss get-scaling x y) + (unbox y))]) + ;; 10.6 only: + #; + (tellv print-info setScalingFactor: #:type _CGFloat scale) + (atomically + (with-autorelease + (tellv (tell print-info dictionary) + setObject: (tell NSNumber numberWithDouble: #:type _double scale) + forKey: NSPrintScalingFactor))))) (define NSOkButton 1) @@ -84,7 +106,7 @@ (send pss set-orientation (if (= o NSLandscapeOrientation) 'landscape 'portrait))) - (let ([s (tell #:type _CGFloat print-info scalingFactor)]) + (let ([s (get-scaling-factor print-info)]) (send pss set-scaling s s)) #t) #f))) @@ -113,7 +135,7 @@ (define-values (page-width page-height page-scaling) (let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))] - [scaling (tell #:type _CGFloat print-info scalingFactor)]) + [scaling (get-scaling-factor print-info)]) (values (NSSize-width s) (NSSize-height s) scaling))) From 6ee3b105c1c012fecc1c7aef32d4fb4ebe1aa58b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Oct 2010 07:31:40 -0600 Subject: [PATCH 305/462] win32: iconize and refresh problems original commit: 3ae3d15d93ad12dabf207cfabcfae5e6065434d8 --- collects/mred/private/wx/win32/frame.rkt | 101 ++++++++++++++++--- collects/mred/private/wx/win32/message.rkt | 2 +- collects/mred/private/wx/win32/panel.rkt | 8 +- collects/mred/private/wx/win32/radio-box.rkt | 2 +- collects/mred/private/wx/win32/window.rkt | 10 +- collects/mred/private/wx/win32/wndclass.rkt | 4 +- 6 files changed, 104 insertions(+), 23 deletions(-) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 76c9fc11..2b8f1d7d 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -81,6 +81,19 @@ WS_EX_TOOLWINDOW WS_EX_TOPMOST)) +(define-cstruct _WINDOWPLACEMENT + ([length _UINT] + [flags _UINT] + [showCmd _UINT] + [ptMinPosition _POINT] + [ptMaxPosition _POINT] + [rcNormalPosition _RECT])) + +(define-user32 GetWindowPlacement (_wfun _HWND _WINDOWPLACEMENT-pointer -> (r : _BOOL) + -> (unless r (failed 'GetWindowPlacement)))) + +(define-user32 IsIconic (_fun _HWND -> _BOOL)) + (defclass frame% window% (init parent label @@ -91,7 +104,6 @@ is-shown? get-eventspace on-size - get-size pre-on-char pre-on-event reset-cursor-in-child) @@ -139,6 +151,17 @@ (define hwnd (get-hwnd)) (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) + ;; record delta between size and client size + ;; for getting the client size when the frame + ;; is iconized: + (define-values (client-dw client-dh) + (let ([w (box 0)] [h (box 0)] + [cw (box 0)] [ch (box 0)]) + (get-size w h) + (get-client-size cw ch) + (values (- (unbox w) (unbox cw)) + (- (unbox h) (unbox ch))))) + (define/public (is-dialog?) #f) (define/override (show on?) @@ -176,13 +199,13 @@ (when (on-close) (direct-show #f)))) 0] - [(= msg WM_SIZE) - (unless (= wParam SIZE_MINIMIZED) - (queue-window-event this (lambda () (on-size 0 0)))) + [(and (= msg WM_SIZE) + (not (= wParam SIZE_MINIMIZED))) + (queue-window-event this (lambda () (on-size 0 0))) (stdret 0 1)] [(= msg WM_MOVE) (queue-window-event this (lambda () (on-size 0 0))) - 0] + (stdret 0 1)] [(= msg WM_ACTIVATE) (let ([state (LOWORD wParam)] [minimized (HIWORD wParam)]) @@ -232,11 +255,6 @@ (define/override (is-enabled-to-root?) #t) - (define/override (get-x) - (RECT-left (GetWindowRect hwnd))) - (define/override (get-y) - (RECT-top (GetWindowRect hwnd))) - (define/public (on-toolbar-click) (void)) (define/public (on-menu-click) (void)) @@ -369,7 +387,67 @@ SW_RESTORE)) (set! hidden-zoomed? (and on? #t)))) - (def/public-unimplemented iconized?) + (define/public (iconized?) + (IsIconic hwnd)) + + (define/public (iconize on?) + (when (is-shown?) + (when (or on? (not (iconized?))) + (ShowWindow hwnd (if on? SW_MINIMIZE SW_RESTORE))))) + + (define/private (get-placement) + (let ([wp (make-WINDOWPLACEMENT + (ctype-sizeof _WINDOWPLACEMENT) + 0 + 0 + (make-POINT 0 0) + (make-POINT 0 0) + (make-RECT 0 0 0 0))]) + (GetWindowPlacement hwnd wp) + wp)) + + (define/override (get-size w h) + (if (iconized?) + (let ([wp (get-placement)]) + (let ([r (WINDOWPLACEMENT-rcNormalPosition wp)]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (super get-size w h))) + + (define/override (get-client-size w h) + (if (iconized?) + (begin + (get-size w h) + (set-box! w (max 1 (- (unbox w) client-dw))) + (set-box! h (max 1 (- (unbox h) client-dh)))) + (super get-client-size w h))) + + (define/override (get-x) + (if (iconized?) + (let ([wp (get-placement)]) + (RECT-left (WINDOWPLACEMENT-rcNormalPosition wp))) + (RECT-left (GetWindowRect hwnd)))) + + (define/override (get-y) + (if (iconized?) + (let ([wp (get-placement)]) + (RECT-top (WINDOWPLACEMENT-rcNormalPosition wp))) + (RECT-top (GetWindowRect hwnd)))) + + (define/override (get-width) + (if (iconized?) + (let ([w (box 0)]) + (get-size w (box 0)) + (unbox w)) + (super get-width))) + + (define/override (get-height) + (if (iconized?) + (let ([h (box 0)]) + (get-size (box 0) h) + (unbox h)) + (super get-height))) + (def/public-unimplemented get-menu-bar) (define menu-bar #f) @@ -414,7 +492,6 @@ (set! big-hicon hicon) (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))) - (def/public-unimplemented iconize) (define/public (set-title s) (atomically (set! saved-title s) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index de6cccdc..b85f46f8 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -80,7 +80,7 @@ (super-new [callback void] [parent parent] [hwnd - (CreateWindowExW (if (string? label) WS_EX_TRANSPARENT 0) + (CreateWindowExW 0 (get-class) (if (string? label) label diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 1ed5ddd6..1485ad6f 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -75,6 +75,8 @@ (define/public (set-item-cursor x y) (void)))) +(define WS_EX_STATICEDGE #x00020000) + (define panel% (class (panel-mixin window%) (init parent @@ -84,12 +86,14 @@ (super-new [parent parent] [hwnd - (CreateWindowExW 0 + (CreateWindowExW (if (memq 'border style) + WS_EX_STATICEDGE + 0) (if (send parent is-frame?) "PLTPanel" "PLTTabPanel") #f - (bitwise-ior WS_CHILD) + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) 0 0 w h (send parent get-client-hwnd) #f diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 1036d206..4509455d 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -58,7 +58,7 @@ [bitmap? (and (label . is-a? . bitmap%) (send label ok?))] [radio-hwnd - (CreateWindowExW WS_EX_TRANSPARENT + (CreateWindowExW 0 "PLTBUTTON" (if (string? label) label diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index ab0a7428..e01fba1b 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -269,11 +269,13 @@ (define/public (paint-children) (void)) (define/public (get-x) - (let ([r (GetWindowRect hwnd)]) - (- (RECT-left r) (send parent get-x)))) + (let ([r (GetWindowRect hwnd)] + [pr (GetWindowRect (send parent get-client-hwnd))]) + (- (RECT-left r) (RECT-left pr)))) (define/public (get-y) - (let ([r (GetWindowRect hwnd)]) - (- (RECT-top r) (send parent get-y)))) + (let ([r (GetWindowRect hwnd)] + [pr (GetWindowRect (send parent get-client-hwnd))]) + (- (RECT-top r) (RECT-top pr)))) (define/public (get-width) (let ([r (GetWindowRect hwnd)]) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index ba0b187e..330f8da6 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -177,9 +177,7 @@ #f (if controls-are-transparent? #f ; transparent - (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) - (cpointer-push-tag! p 'HBRUSH) - p)) + background-hbrush) #f ; menu "PLTTabPanel"))) From 01a656c32fb9f42da809460930c710057365cb66 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Oct 2010 16:44:49 -0600 Subject: [PATCH 306/462] gtk: on-activate and single-instance fixes original commit: c4ab7733c131676079fb6ed6c29c7b22ec20baca --- collects/mred/private/wx/gtk/frame.rkt | 17 +++++++++++++++++ collects/mred/private/wx/gtk/unique.rkt | 15 +++++++++++++-- collects/mred/private/wx/gtk/window.rkt | 2 ++ 3 files changed, 32 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 061e3b41..c9be2bc2 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -175,6 +175,7 @@ (connect-delete gtk) (connect-configure gtk) + (connect-focus gtk) (define saved-title (or label "")) (define is-modified? #f) @@ -354,6 +355,22 @@ (gtk_window_set_icon_list gtk l) (g_list_free l)))))) + (define child-has-focus? #f) + (define reported-activate #f) + (define queued-active? #f) + (define/public (on-focus-child on?) + ;; atomic mode + (set! child-has-focus? on?) + (unless queued-active? + (set! queued-active? #t) + (queue-window-event this + (lambda () + (let ([on? child-has-focus?]) + (set! queued-active? #f) + (unless (eq? on? reported-activate) + (set! reported-activate on?) + (on-activate on?))))))) + (define/override (call-pre-on-event w e) (pre-on-event w e)) (define/override (call-pre-on-char w e) diff --git a/collects/mred/private/wx/gtk/unique.rkt b/collects/mred/private/wx/gtk/unique.rkt index 9ab6255d..ca139be8 100644 --- a/collects/mred/private/wx/gtk/unique.rkt +++ b/collects/mred/private/wx/gtk/unique.rkt @@ -3,6 +3,7 @@ ffi/unsafe/define racket/draw/bstr net/base64 + "../common/queue.rkt" "types.rkt" "utils.rkt") @@ -41,6 +42,16 @@ (define-signal-handler connect-message-received "message-received" (_fun _UniqueApp _int _UniqueMessageData _uint -> _int) (lambda (app cmd data time) + (let ([d (unique_message_data_get data)]) + (with-handlers ([exn:fail? (lambda (exn) + (log-error + (format "error handling single-instance message: ~s" + (exn-message exn))))]) + (let* ([p (open-input-bytes d)] + [vec (read p)]) + (for-each + queue-file-event + (map string->path (vector->list vec)))))) UNIQUE_RESPONSE_OK)) (define-mz gethostname (_fun _pointer _long -> _int) @@ -65,7 +76,7 @@ (format "~a~a~a" host path (version))))))) (define (encode s) - (regexp-replace* #rx"\r\n" (base64-encode (string->bytes/utf-8 s)) "")) + (regexp-replace* #rx"=|\r\n" (base64-encode (string->bytes/utf-8 s)) "")) (define (send-command-line app) (let ([msg (unique_message_data_new)] @@ -83,4 +94,4 @@ (when (= (send-command-line app) UNIQUE_RESPONSE_OK) (exit 0))) - (connect-message-received app)))) + (void (connect-message-received app))))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index f68f784a..bfa81ac8 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -129,6 +129,7 @@ (lambda (gtk event) (let ([wx (gtk->wx gtk)]) (when wx + (send (send wx get-top-win) on-focus-child #t) (queue-window-event wx (lambda () (send wx on-set-focus)))) #f))) (define-signal-handler connect-focus-out "focus-out-event" @@ -136,6 +137,7 @@ (lambda (gtk event) (let ([wx (gtk->wx gtk)]) (when wx + (send (send wx get-top-win) on-focus-child #f) (queue-window-event wx (lambda () (send wx on-kill-focus)))) #f))) (define (connect-focus gtk) From 4e249b61a8a8ec87e88ffccba9cda7bd13345b4c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Oct 2010 17:28:29 -0700 Subject: [PATCH 307/462] fix save-file and get-argb-pixels for screen bitmaps original commit: 674d2e524858398f715b391d565153ced0443e45 --- collects/mred/private/wx/cocoa/dc.rkt | 14 +++++++++++--- collects/scribblings/gui/blurbs.rkt | 3 ++- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 72e77eaa..aaa1bc4d 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -26,9 +26,17 @@ (super-make-object (make-alternate-bitmap-kind w h)) (define s - (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32 - w - h)) + (let ([s (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32 + w + h)]) + ;; initialize bitmap to empty - needed? + #; + (let ([cr (cairo_create s)]) + (cairo_set_operator cr CAIRO_OPERATOR_CLEAR) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + s)) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/collects/scribblings/gui/blurbs.rkt b/collects/scribblings/gui/blurbs.rkt index bd23f1db..425a7eef 100644 --- a/collects/scribblings/gui/blurbs.rkt +++ b/collects/scribblings/gui/blurbs.rkt @@ -4,7 +4,8 @@ scribble/manual scribble/scheme scribble/decode - (for-label scheme/gui/base) + (for-label scheme/gui/base + scheme/base) (for-syntax scheme/base)) (provide (except-out (all-defined-out) p define-inline)) From 5178a2ef1b650466e160fd4dcd528cec868e9a49 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Oct 2010 09:50:22 -0600 Subject: [PATCH 308/462] gtk: configurable control font original commit: 93d59f4cf5bf6c616d6ebc45a54786061d86f6d1 --- collects/mred/private/wx/gtk/button.rkt | 6 +++++- collects/mred/private/wx/gtk/choice.rkt | 3 +++ collects/mred/private/wx/gtk/item.rkt | 24 ++++++++++++++++++---- collects/mred/private/wx/gtk/list-box.rkt | 1 + collects/mred/private/wx/gtk/message.rkt | 1 + collects/mred/private/wx/gtk/radio-box.rkt | 2 ++ 6 files changed, 32 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 3c207178..a064b586 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -38,7 +38,7 @@ [gtk_new_with_mnemonic gtk_button_new_with_mnemonic] [gtk_new gtk_button_new]) (init-field [event-type 'button]) - (inherit get-gtk set-auto-size is-window-enabled? + (inherit get-gtk get-client-gtk set-auto-size is-window-enabled? get-window-gtk) (super-new [parent parent] @@ -58,6 +58,7 @@ [else (as-gtk-allocation (gtk_new_with_mnemonic ""))])] [callback cb] + [font font] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) @@ -81,6 +82,9 @@ ;; Called from event-handling thread (queue-window-event this (lambda () (clicked)))) + (define/override (get-label-gtk) + (gtk_bin_get_child (get-client-gtk))) + (define/override (set-label s) (cond [(string? s) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 0f79c489..9127a229 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -21,6 +21,7 @@ (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) (define-signal-handler connect-changed "changed" (_fun _GtkWidget -> _void) @@ -53,6 +54,8 @@ (gtk_combo_box_set_active gtk 0) + (install-control-font (gtk_bin_get_child gtk) font) + (set-auto-size) (connect-changed gtk) diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt index b2fa259a..e63bfada 100644 --- a/collects/mred/private/wx/gtk/item.rkt +++ b/collects/mred/private/wx/gtk/item.rkt @@ -1,20 +1,36 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw/local "../../syntax.rkt" - "window.rkt") + "window.rkt" + "utils.rkt" + "types.rkt") -(provide item%) +(provide item% + install-control-font) + +(define _PangoFontDescription _pointer) +(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)) + +(define (install-control-font gtk font) + (when font + (gtk_widget_modify_font gtk (send font get-pango)))) (defclass item% window% (inherit get-client-gtk) (init-field [callback void]) + (init [font #f]) (super-new) (let ([client-gtk (get-client-gtk)]) (connect-focus client-gtk) (connect-key-and-mouse client-gtk)) + (install-control-font (get-label-gtk) font) + + (define/public (get-label-gtk) (get-client-gtk)) (def/public-unimplemented set-label) (def/public-unimplemented get-label) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 1fdb8638..291ea5c3 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -116,6 +116,7 @@ [gtk gtk] [extra-gtks (list client-gtk selection)] [callback cb] + [font font] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index aa3c26b9..d74513fd 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -66,6 +66,7 @@ (release-pixbuf pixbuf))) (as-gtk-allocation (gtk_label_new_with_mnemonic "")))))] + [font font] [no-show? (memq 'deleted style)]) (when (string? label) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 8bb12b75..6039e5d4 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -26,6 +26,7 @@ (define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) (define-signal-handler connect-clicked "clicked" (_fun _GtkWidget -> _void) @@ -64,6 +65,7 @@ [else (gtk_radio_button_new_with_mnemonic #f "")])]) (gtk_box_pack_start gtk radio-gtk #t #t 0) + (install-control-font (gtk_bin_get_child radio-gtk) font) (gtk_widget_show radio-gtk) radio-gtk)))) (for ([radio-gtk (in-list (cdr radio-gtks))]) From 512c557e72e7ad27632472d685b99d779d82b08a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Oct 2010 10:08:16 -0600 Subject: [PATCH 309/462] gtk: use system preference for font original commit: 42dc870c10086a9816c08b19527044dc993f6845 --- collects/mred/private/gdi.rkt | 23 +++++++----- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 2 ++ collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 40 +++++++++++++++++++-- collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 2 ++ 8 files changed, 59 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 36b3cad6..767e1f6f 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -238,18 +238,23 @@ [(windows) 1] [else 2])) - (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system - 'normal 'normal #f 'default - (wx:get-control-font-size-in-pixels?))) - (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system - 'normal 'normal #f 'default - (wx:get-control-font-size-in-pixels?))) - (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system + (define normal-control-font (make-object wx:font% (wx:get-control-font-size) + (wx:get-control-font-face) 'system 'normal 'normal #f 'default (wx:get-control-font-size-in-pixels?))) + (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) (define view-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (- (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (- (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font)) (define menu-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (+ (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (+ (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index b53bfef3..98b0bfa7 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -65,6 +65,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index e7f61406..7b77f911 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -44,6 +44,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -89,6 +90,7 @@ (define (get-double-click-time) 500) +(define (get-control-font-face) "Lucida Grande") (define (get-control-font-size) 13) (define (get-control-font-size-in-pixels?) #f) (define (cancel-quit) (void)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 40eef1d4..9f1d9eb2 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -65,6 +65,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 294ec927..3ab44b98 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -37,6 +37,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -81,9 +82,42 @@ (define run-printout (make-run-printout printer-dc%)) -(define (get-double-click-time) 250) -(define (get-control-font-size) 10) ;; FIXME -(define (get-control-font-size-in-pixels?) #f) ;; FIXME +(define _GtkSettings (_cpointer 'GtkSettings)) +(define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) +(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) +(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) + +(define (get-double-click-time) + (let ([s (gtk_settings_get_default)]) + (if s + (g_object_get/int s "gtk-double-click-time") + 250))) +(define (get-control-font proc default) + (or + (let ([s (gtk_settings_get_default)]) + (and s + (let ([f (g_object_get/string s "gtk-font-name")]) + (and f + (begin0 + (cond + [(regexp-match #rx"^(.*) ([0-9]+)$" (cast f _pointer _string)) + => (lambda (m) (proc (cdr m)))] + [else #f]) + (g_free f)))))) + default)) +(define (get-control-font-size) + (get-control-font (lambda (m) (string->number (cadr m))) + 10)) +(define (get-control-font-face) + (get-control-font (lambda (m) (car m)) + "Sans")) +(define (get-control-font-size-in-pixels?) #f) (define (get-display-depth) 32) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 5cf54c11..448aa92c 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 167ca364..07c3629e 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -66,6 +66,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index be571ada..9a4b70b4 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -37,6 +37,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -84,6 +85,7 @@ (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 500) +(define (get-control-font-face) "Tahoma") (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) (define (flush-display) (void)) From ad2e66afb391e7ff2c176f5b336975982b4409c0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Oct 2010 14:50:58 -0600 Subject: [PATCH 310/462] cocoa: control fonts original commit: ca64c25cf9f897c888531ef7ddf6b64260423d8e --- collects/mred/private/wx/cocoa/font.rkt | 48 +++++++++++++++++++++ collects/mred/private/wx/cocoa/item.rkt | 9 ++-- collects/mred/private/wx/cocoa/list-box.rkt | 13 +++++- collects/tests/gracket/item.rkt | 9 +++- 4 files changed, 72 insertions(+), 7 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/font.rkt diff --git a/collects/mred/private/wx/cocoa/font.rkt b/collects/mred/private/wx/cocoa/font.rkt new file mode 100644 index 00000000..7b438b0a --- /dev/null +++ b/collects/mred/private/wx/cocoa/font.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + ffi/unsafe/objc + "../../lock.rkt" + "const.rkt" + "utils.rkt" + "types.rkt") + +(provide font->NSFont) + +(import-class NSFont NSFontManager) + +(define NSItalicFontMask #x00000001) +(define NSBoldFontMask #x00000002) + +(define (font->NSFont f) + (let* ([weight (send f get-weight)] + [style (send f get-style)] + [name (or (send f get-face) + (send the-font-name-directory + get-screen-name + (send the-font-name-directory + find-family-default-font-id + (send f get-family)) + weight + style))]) + (atomically + (with-autorelease + (let ([f (tell NSFont + fontWithName: #:type _NSString name + size: #:type _CGFloat (send f get-point-size))]) + (if (and (eq? 'normal weight) + (eq? 'normal style)) + (begin + (retain f) + f) + (let ([fm (tell NSFontManager sharedFontManager)]) + (let ([f (tell fm + convertFont: f + toHaveTrait: #:type _int (bitwise-ior + (if (eq? weight 'bold) NSBoldFontMask 0) + (if (eq? style 'italic) NSItalicFontMask 0)))]) + (begin + (retain f) + f))))))))) + \ No newline at end of file diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 571295bf..6f3a0443 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -2,10 +2,11 @@ (require scheme/class scheme/foreign ffi/objc - "../../syntax.rkt" + "../../syntax.rkt" "window.rkt" "const.rkt" - "types.rkt") + "types.rkt" + "font.rkt") (unsafe!) (objc-unsafe!) @@ -17,7 +18,9 @@ systemFontOfSize: #:type _CGFloat 13)) (define (install-control-font cocoa font) - (tellv cocoa setFont: sys-font)) + (if font + (tellv cocoa setFont: (font->NSFont font)) + (tellv cocoa setFont: sys-font))) (defclass item% window% (inherit get-cocoa) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index e25fb0f1..f5bffb68 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -10,6 +10,7 @@ "types.rkt" "const.rkt" "window.rkt" + "font.rkt" "../common/event.rkt") (unsafe!) (objc-unsafe!) @@ -27,8 +28,12 @@ [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (let ([wx (->wx wxb)]) (tell - (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-row row) "???")) + (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???"))] + [font (send wx get-cell-font)]) + (when font + (tellv c setFont: font)) + c) autorelease))] [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] @@ -106,6 +111,10 @@ (def/public-unimplemented get-label-font) + (define cell-font (and font (font->NSFont font))) + (define/public (get-cell-font) + cell-font) + (define/public (get-selection) (tell #:type _NSInteger content-cocoa selectedRow)) (define/public (get-selections) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index e8bd6f9a..4e32dd54 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -50,6 +50,10 @@ 20 'decorative 'normal 'bold #f)) +(define italic-font (send the-font-list find-or-create-font + 13 'roman + 'italic 'normal + #f)) (define ($ font) (or font normal-control-font)) (define (make-h&s cp f) @@ -2253,7 +2257,7 @@ (make-radio-box "Stretchiness" '("Normal" "All Stretchy") p1 void)) (define font-radio - (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big") + (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big" "Italic") p1 void)) (define enabled-radio (make-radio-box "Initially" '("Enabled" "Disabled") @@ -2276,7 +2280,8 @@ (list-ref (list #f small-control-font tiny-control-font - special-font) + special-font + italic-font) (send font-radio get-selection)) (positive? (send enabled-radio get-selection)) (positive? (send selection-radio get-selection)) From 4c17e006b81459f22399f16cdff5fff5c1f95151 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Oct 2010 20:44:40 -0600 Subject: [PATCH 311/462] cocoa: avoid 10.6-only clipboard method original commit: be5920618d2dc52a2e00d95bdfb3569733cfc732 --- collects/mred/private/wx/cocoa/clipboard.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index c1c2dd73..e1e7ebf8 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -56,7 +56,9 @@ [a (tell NSArray arrayWithObjects: #:type (_list i _NSString) (map map-type types) count: #:type _NSUInteger (length types))]) - (set! counter (tell #:type _NSInteger pb clearContents)) + (set! counter (tell #:type _NSInteger pb + declareTypes: a + owner: #f)) (set! client c) (for ([type (in-list types)]) (let* ([bstr (send c get-data type)] From d8abd252d3fd2a8fd8991a91ef1888356c25087f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 Oct 2010 16:09:21 -0700 Subject: [PATCH 312/462] cocoa: bitmap from clipboard original commit: 56f311d204948031a4b67f8bb33ddae2213c037f --- collects/mred/private/wx/cocoa/clipboard.rkt | 13 ++++++-- collects/mred/private/wx/cocoa/dc.rkt | 31 +---------------- collects/mred/private/wx/cocoa/image.rkt | 33 ++++++++++++++++++- collects/mred/private/wx/common/clipboard.rkt | 2 +- collects/mred/private/wx/gtk/clipboard.rkt | 3 ++ collects/mred/private/wx/win32/clipboard.rkt | 3 ++ 6 files changed, 51 insertions(+), 34 deletions(-) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index e1e7ebf8..d72d854a 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -4,6 +4,7 @@ ffi/unsafe/objc "utils.rkt" "types.rkt" + "image.rkt" "../common/bstr.rkt" "../../syntax.rkt" "../../lock.rkt") @@ -11,7 +12,7 @@ (provide clipboard-driver% has-x-selection?) -(import-class NSPasteboard NSArray NSData) +(import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext) (import-protocol NSPasteboardOwner) (define (has-x-selection?) #f) @@ -85,4 +86,12 @@ (and data (let ([len (tell #:type _NSUInteger data length)] [bstr (tell #:type _pointer data bytes)]) - (scheme_make_sized_byte_string bstr len 1)))))))) + (scheme_make_sized_byte_string bstr len 1))))))) + + (define/public (get-bitmap-data) + (atomically + (with-autorelease + (let ([i (tell (tell NSImage alloc) + initWithPasteboard: (tell NSPasteboard generalPasteboard))]) + (and i + (image->bitmap i))))))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index aaa1bc4d..cd44ad58 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -8,6 +8,7 @@ racket/draw/gl-context "types.rkt" "utils.rkt" + "bitmap.rkt" "window.rkt" "../../lock.rkt" "../common/queue.rkt" @@ -20,36 +21,6 @@ (import-class NSOpenGLContext) -(define quartz-bitmap% - (class bitmap% - (init w h) - (super-make-object (make-alternate-bitmap-kind w h)) - - (define s - (let ([s (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32 - w - h)]) - ;; initialize bitmap to empty - needed? - #; - (let ([cr (cairo_create s)]) - (cairo_set_operator cr CAIRO_OPERATOR_CLEAR) - (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) - (cairo_paint cr) - (cairo_destroy cr)) - s)) - - (define/override (ok?) #t) - (define/override (is-color?) #t) - - (define/override (get-cairo-surface) s) - (define/override (get-cairo-alpha-surface) s) - - (define/override (release-bitmap-storage) - (atomically - (when s - (cairo_surface_destroy s) - (set! s #f)))))) - (define dc% (class backing-dc% (init [(cnvs canvas)]) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index ba1251db..e8ebe30f 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -2,18 +2,24 @@ (require ffi/unsafe ffi/unsafe/objc racket/class + racket/draw/cairo + racket/draw/local "../common/bstr.rkt" "utils.rkt" "types.rkt" "const.rkt" "cg.rkt" + "bitmap.rkt" "../../lock.rkt" (only-in '#%foreign ffi-callback)) -(provide bitmap->image) +(provide bitmap->image + image->bitmap) (import-class NSImage NSGraphicsContext) +(define NSCompositeCopy 1) + (define _CGImageRef (_cpointer 'CGImageRef)) (define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef)) (define _CGDataProviderRef (_cpointer 'GCDataProviderRef)) @@ -103,3 +109,28 @@ (tellv i unlockFocus) i)))))) +(define (image->bitmap i) + (let* ([s (tell #:type _NSSize i size)] + [w (NSSize-width s)] + [h (NSSize-height s)] + [bm (make-object quartz-bitmap% + (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))] + [surface (let ([s (send bm get-cairo-surface)]) + (cairo_surface_flush s) + s)] + [cg (cairo_quartz_surface_get_cg_context surface)] + [gc (tell NSGraphicsContext + graphicsContextWithGraphicsPort: #:type _pointer cg + flipped: #:type _BOOL #f)]) + (CGContextSaveGState cg) + (CGContextTranslateCTM cg 0 h) + (CGContextScaleCTM cg 1 -1) + (tellv NSGraphicsContext saveGraphicsState) + (tellv NSGraphicsContext setCurrentContext: gc) + (let ([r (make-NSRect (make-NSPoint 0 0) (make-NSSize w h))]) + (tellv i drawInRect: #:type _NSRect r fromRect: #:type _NSRect r + operation: #:type _int NSCompositeCopy fraction: #:type _CGFloat 1.0)) + (tellv NSGraphicsContext restoreGraphicsState) + (CGContextRestoreGState cg) + bm)) diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt index 7d96c062..caee9e65 100644 --- a/collects/mred/private/wx/common/clipboard.rkt +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -37,7 +37,7 @@ (eq? c (send driver get-client))) (def/public (get-clipboard-bitmap [exact-integer? timestamp]) - #f) + (send driver get-bitmap-data)) (def/public-unimplemented set-clipboard-bitmap) (def/public (get-clipboard-data [string? type] [exact-integer? timestamp]) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index fc25fa0c..8c2557c2 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -171,5 +171,8 @@ (define/public (get-text-data) (or (gtk_clipboard_wait_for_text cb) "")) + (define/public (get-bitmap-data) + #f) + (super-new)) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index 355cbc53..f55884c4 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -152,5 +152,8 @@ (define/public (get-text-data) (or (get-data "TEXT" #t) "")) + + (define/public (get-bitmap-data) + #f) (super-new)) From d5cf86d7c0b3645db8f20b7ea7815bf2e22afdab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 Oct 2010 22:10:39 -0700 Subject: [PATCH 313/462] gtk: image paste original commit: ad9209f1e98f7569e5c6d3dcefe4f529d0dcec55 --- collects/mred/private/wx/gtk/clipboard.rkt | 29 ++++++++++++++++------ collects/mred/private/wx/gtk/pixbuf.rkt | 26 ++++++++++++++++--- collects/mred/private/wx/gtk/utils.rkt | 2 ++ 3 files changed, 46 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 8c2557c2..e74f3d23 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -1,14 +1,15 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" "../common/bstr.rkt" "utils.rkt" - "types.rkt") -(unsafe!) + "types.rkt" + "pixbuf.rkt") (provide clipboard-driver% has-x-selection? @@ -23,6 +24,13 @@ (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) +(define _freed-string (make-ctype _pointer + (lambda (s) s) + (lambda (p) + (let ([s (cast p _pointer _string)]) + (g_free p) + s)))) + ;; Recent versions of Gtk provide function calls to ;; access data, but use structure when the functions are ;; not available @@ -54,7 +62,9 @@ #:fail (lambda () GtkSelectionDataT-length)) (define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer) #:fail (lambda () GtkSelectionDataT-data)) -(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _string)) +(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _freed-string)) +(define-gtk gtk_clipboard_wait_for_image (_fun _GtkClipboard -> _GdkPixbuf) + #:wrap (allocator gobject-unref)) (define-cstruct _GtkTargetEntry ([target _pointer] [flags _uint] @@ -172,7 +182,10 @@ (or (gtk_clipboard_wait_for_text cb) "")) (define/public (get-bitmap-data) - #f) + (let ([pixbuf (gtk_clipboard_wait_for_image cb)]) + (and pixbuf + (begin0 + (pixbuf->bitmap pixbuf) + (gobject-unref pixbuf))))) (super-new)) - diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index d6112203..e89507a6 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -3,18 +3,22 @@ ffi/unsafe ffi/unsafe/alloc racket/draw + racket/draw/local + racket/draw/cairo "../../lock.rkt" "../common/bstr.rkt" "utils.rkt" "types.rkt" (only-in '#%foreign ffi-callback)) -(provide _GdkPixbuf - bitmap->pixbuf +(provide bitmap->pixbuf + pixbuf->bitmap + + _GdkPixbuf gtk_image_new_from_pixbuf release-pixbuf) -(define _GdkPixbuf (_cpointer 'GdkPixbuf)) +(define _GdkPixbuf (_cpointer/null 'GdkPixbuf)) (define release-pixbuf ((deallocator) g_object_unref)) @@ -31,6 +35,10 @@ -> _GdkPixbuf) #:wrap (allocator release-pixbuf)) +(define-gdk gdk_cairo_set_source_pixbuf (_fun _cairo_t _GdkPixbuf _double* _double* -> _void)) +(define-gdk gdk_pixbuf_get_width (_fun _GdkPixbuf -> _int)) +(define-gdk gdk_pixbuf_get_height (_fun _GdkPixbuf -> _int)) + (define free-it (ffi-callback free (list _pointer) _void @@ -59,3 +67,15 @@ (* w 4) free-it #f))))) + +(define (pixbuf->bitmap pixbuf) + (let* ([w (gdk_pixbuf_get_width pixbuf)] + [h (gdk_pixbuf_get_height pixbuf)] + [bm (make-object bitmap% w h #f #t)] + [s (send bm get-cairo-surface)] + [cr (cairo_create s)]) + (gdk_cairo_set_source_pixbuf cr pixbuf 0 0) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_destroy cr) + bm)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 7b879119..f92202c1 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -28,6 +28,7 @@ g_free _gpath/free _GSList + gfree g_object_set_data g_object_get_data @@ -132,6 +133,7 @@ v))))) (define-glib g_free (_fun _pointer -> _void)) +(define gfree ((deallocator) g_free)) (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) From ce0759e490a0bff48fd9ab4ec37a5d576611a5b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 Oct 2010 15:59:10 -0600 Subject: [PATCH 314/462] win32: control font original commit: df94c048236f2e722c8af80364086217812cef44 --- collects/mred/private/wx/win32/button.rkt | 8 +-- collects/mred/private/wx/win32/check-box.rkt | 4 +- collects/mred/private/wx/win32/choice.rkt | 3 +- collects/mred/private/wx/win32/font.rkt | 23 +++++++ .../mred/private/wx/win32/group-panel.rkt | 2 +- collects/mred/private/wx/win32/message.rkt | 2 +- collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/radio-box.rkt | 7 ++- collects/mred/private/wx/win32/slider.rkt | 3 +- collects/mred/private/wx/win32/tab-panel.rkt | 3 +- collects/mred/private/wx/win32/window.rkt | 63 ++++++++++--------- 11 files changed, 76 insertions(+), 44 deletions(-) create mode 100644 collects/mred/private/wx/win32/font.rkt diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index e3d86b84..f455c192 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -64,13 +64,13 @@ (define/public (get-button-background) #xFFFFFF) - (define/public (auto-size-button label) + (define/public (auto-size-button font label) (cond [bitmap? - (auto-size label 0 0 4 4)] + (auto-size font label 0 0 4 4)] [else - (auto-size label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) - (auto-size-button label) + (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) + (auto-size-button font label) (subclass-control (get-hwnd)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 5eae81ad..675e4ae0 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -22,8 +22,8 @@ (define/override (get-button-background) (GetSysColor COLOR_BTNFACE)) - (define/override (auto-size-button label) - (auto-size label 0 0 20 0)) + (define/override (auto-size-button font label) + (auto-size font label 0 0 20 0)) (define/public (set-value v) (void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index a9de92b2..a584a698 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -58,7 +58,8 @@ (set-control-font font) ;; setting the choice height somehow sets the ;; popup-menu size, not the control that you see - (auto-size (if (null? choices) (list "Choice") choices) + (auto-size font + (if (null? choices) (list "Choice") choices) 0 0 40 0 (lambda (w h) (set-size -11111 -11111 w (* h 8)))) diff --git a/collects/mred/private/wx/win32/font.rkt b/collects/mred/private/wx/win32/font.rkt new file mode 100644 index 00000000..4017c643 --- /dev/null +++ b/collects/mred/private/wx/win32/font.rkt @@ -0,0 +1,23 @@ +#lang racket +(require racket/class + racket/draw/local + racket/draw/pango) + +(provide font->hfont) + +(define display-font-map + (pango_win32_font_map_for_display)) + +(define display-context + (pango_font_map_create_context display-font-map)) + +(define font-cache (pango_win32_font_cache_new)) + +(define (font->hfont f) + (let* ([pfont (pango_font_map_load_font display-font-map + display-context + (send f get-pango))] + [logfont (pango_win32_font_logfont pfont)]) + (begin0 + (pango_win32_font_cache_load font-cache logfont) + (g_free logfont)))) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 3d7e7ff2..d77aabda 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -58,7 +58,7 @@ (define label-h 0) (set-control-font #f) - (auto-size label 0 0 0 0 + (auto-size #f label 0 0 0 0 (lambda (w h) (set! label-h h) (set-size -11111 -11111 (+ w 10) (+ h 10)))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index b85f46f8..1fd05984 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -118,7 +118,7 @@ (if (symbol? label) (set-size -11111 -11111 32 32) - (auto-size label 0 0 0 0)) + (auto-size font label 0 0 0 0)) (define/override (get-setimage-message) STM_SETIMAGE))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 9a4b70b4..32153d9a 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -85,7 +85,7 @@ (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 500) -(define (get-control-font-face) "Tahoma") +(define (get-control-font-face) (get-theme-font-face)) (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) (define (flush-display) (void)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 4509455d..6b3b66df 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -80,9 +80,10 @@ (ShowWindow radio-hwnd SW_SHOW) (set-control-font font radio-hwnd) (let-values ([(w1 h) - (auto-size label 0 0 20 4 (lambda (w h) - (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) - (values w h)))]) + (auto-size font label 0 0 20 4 + (lambda (w h) + (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) + (values w h)))]) (cons radio-hwnd (loop (+ y SEP h) (max w1 w) (cdr labels)))))))) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 7ae2fedf..2310b8c7 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -112,7 +112,8 @@ (define value-h 0) (if panel-hwnd - (auto-size (list (format "~s" lo) + (auto-size font + (list (format "~s" lo) (format "~s" hi)) 0 0 0 0 (lambda (w h) (set! value-w w) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 9e01b259..03b4dea1 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -97,7 +97,8 @@ (define tab-height 0) (set-control-font #f) - (auto-size (if (null? choices) + (auto-size #f + (if (null? choices) '("Choice") choices) 0 0 0 0 #:combine-width + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index e01fba1b..d3fd91eb 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -16,7 +16,8 @@ "queue.rkt" "theme.rkt" "cursor.rkt" - "key.rkt") + "key.rkt" + "font.rkt") (provide window% queue-window-event @@ -306,41 +307,45 @@ (define/public (set-control-font font [hwnd hwnd]) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)) + (let ([hfont (if font + (font->hfont font) + theme-hfont)]) + (SendMessageW hwnd WM_SETFONT (cast hfont _HFONT _LPARAM) 0))) - (define/public (auto-size label min-w min-h dw dh + (define/public (auto-size font label min-w min-h dw dh [resize (lambda (w h) (set-size -11111 -11111 w h))] #:combine-width [combine-w max] #:combine-height [combine-h max] #:scale-w [scale-w 1] #:scale-h [scale-h 1]) - (unless measure-dc - (let* ([bm (make-object bitmap% 1 1)] - [dc (make-object bitmap-dc% bm)] - [font (make-object font% 8 'system)]) - (send dc set-font font) - (set! measure-dc dc))) - (let-values ([(w h d a) (let loop ([label label]) - (cond - [(null? label) (values 0 0 0 0)] - [(label . is-a? . bitmap%) - (values (send label get-width) - (send label get-height) - 0 - 0)] - [(pair? label) - (let-values ([(w1 h1 d1 a1) - (loop (car label))] - [(w2 h2 d2 a2) - (loop (cdr label))]) - (values (combine-w w1 w2) (combine-h h1 h2) - (combine-h d1 d1) (combine-h a1 a2)))] - [else - (send measure-dc get-text-extent label #f #t)]))] - [(->int) (lambda (v) (inexact->exact (floor v)))]) - (resize (->int (* scale-h (max (+ w dw) min-w))) - (->int (* scale-w (max (+ h dh) min-h)))))) + (atomically + (unless measure-dc + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (set! measure-dc dc))) + (send measure-dc set-font (or font + (make-object font% 8 'system))) + (let-values ([(w h d a) (let loop ([label label]) + (cond + [(null? label) (values 0 0 0 0)] + [(label . is-a? . bitmap%) + (values (send label get-width) + (send label get-height) + 0 + 0)] + [(pair? label) + (let-values ([(w1 h1 d1 a1) + (loop (car label))] + [(w2 h2 d2 a2) + (loop (cdr label))]) + (values (combine-w w1 w2) (combine-h h1 h2) + (combine-h d1 d1) (combine-h a1 a2)))] + [else + (send measure-dc get-text-extent label #f #t)]))] + [(->int) (lambda (v) (inexact->exact (floor v)))]) + (resize (->int (* scale-h (max (+ w dw) min-w))) + (->int (* scale-w (max (+ h dh) min-h))))))) (define/public (popup-menu m x y) (let ([gx (box x)] From 6b486c622eeafa6026e1d0421164e10d8018007b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 Oct 2010 08:05:54 -0600 Subject: [PATCH 315/462] win32: paste bitmap original commit: 003ba8439a8196c90f450174607b987123c6dfb1 --- collects/mred/private/wx/win32/clipboard.rkt | 103 ++++++++++++++++++- collects/mred/private/wx/win32/hbitmap.rkt | 39 ++++++- 2 files changed, 139 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index f55884c4..9fca7274 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -9,7 +9,8 @@ "utils.rkt" "const.rkt" "../../syntax.rkt" - "wndclass.rkt") + "wndclass.rkt" + "hbitmap.rkt") (provide clipboard-driver% has-x-selection?) @@ -27,6 +28,31 @@ #f)) (define CF_UNICODETEXT 13) +(define CF_BITMAP 2) +(define CF_DIB 8) + +(define DIB_RGB_COLORS 0) +(define SRCCOPY #x00CC0020) + +(define-cstruct _BITMAPINFOHEADER + ([biSize _DWORD] + [biWidth _LONG] + [biHeight _LONG] + [biPlanes _WORD] + [biBitCount _WORD] + [biCompression _DWORD] + [biSizeImage _DWORD] + [biXPelsPerMeter _LONG] + [biYPelsPerMeter _LONG] + [biClrUsed _DWORD] + [biClrImportant _DWORD])) + +(define-cstruct _BITMAPCOREHEADER + ([bcSize _DWORD] + [bcWidth _LONG] + [bcHeight _LONG] + [bcPlanes _WORD] + [bcBitCount _WORD])) (define-user32 GetClipboardOwner (_wfun -> _HWND)) (define-user32 OpenClipboard (_wfun _HWND -> _BOOL)) @@ -60,6 +86,10 @@ (define-user32 GetClipboardData (_wfun _UINT -> _HANDLE)) +(define-gdi32 StretchDIBits(_wfun _HDC _int _int _int _int _int _int _int _int + _pointer _BITMAPINFOHEADER-pointer _UINT _DWORD + -> _int)) + (define GHND #x0042) (defclass clipboard-driver% object% @@ -154,6 +184,75 @@ (or (get-data "TEXT" #t) "")) (define/public (get-bitmap-data) - #f) + (atomically + (and (OpenClipboard clipboard-owner-hwnd) + (begin0 + (get-bitmap-from-clipboard) + (CloseClipboard))))) (super-new)) + + +(define (get-bitmap-from-clipboard) + ;; atomic mode + (cond + ;; I think we should be able to use CF_BITMAP always, but + ;; it doesn't work right under Windows XP with a particular + ;; image created by copying in Firefox. So, we do things the + ;; hard way. + [(GetClipboardData CF_DIB) + => (lambda (bits) + (let ([bmi (cast (GlobalLock bits) _pointer _BITMAPINFOHEADER-pointer)]) + (let ([w (BITMAPINFOHEADER-biWidth bmi)] + [h (BITMAPINFOHEADER-biHeight bmi)] + [bits/pp (BITMAPINFOHEADER-biBitCount bmi)]) + (let* ([screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [hbitmap (if (= bits/pp 1) + (CreateBitmap w h 1 1 #f) + (CreateCompatibleBitmap screen-hdc w h))] + [old-hbitmap (SelectObject hdc hbitmap)] + [psize (PaletteSize bmi)]) + (ReleaseDC #f screen-hdc) + (StretchDIBits hdc 0 0 w h + 0 0 w h + (ptr-add bmi (+ (BITMAPINFOHEADER-biSize bmi) psize)) + bmi DIB_RGB_COLORS SRCCOPY) + (SelectObject hdc old-hbitmap) + (GlobalUnlock bits) + (DeleteDC hdc) + (begin0 + (hbitmap->bitmap hbitmap) + (DeleteObject hbitmap))))))] + [(GetClipboardData CF_BITMAP) + => (lambda (hbitmap) + (hbitmap->bitmap hbitmap))] + [else #f])) + +;; Copied from MS example: + +(define (DibNumColors bmc? bmi) + ;; /* With the BITMAPINFO format headers, the size of the palette + ;; * is in biClrUsed, whereas in the BITMAPCORE - style headers, it + ;; * is dependent on the bits per pixel ( = 2 raised to the power of + ;; * bits/pixel). + ;; */ + (if (and (not bmc?) + (not (zero? (BITMAPINFOHEADER-biClrUsed bmi)))) + (BITMAPINFOHEADER-biClrUsed bmi) + (let ([bits (BITMAPINFOHEADER-biBitCount bmi)]) + (case bits + [(1) 2] + [(4) 16] + [(8) 256] + [else + ;; A 24 bitcount DIB has no color table + 0])))) + +(define (PaletteSize bmi) + (let* ([bmc? (= (BITMAPINFOHEADER-biSize bmi) + (ctype-sizeof _BITMAPCOREHEADER))] + [num-colors (DibNumColors bmc? bmi)]) + (if bmc? + (* num-colors 3) + (* num-colors 4)))) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index 81e327c5..8f3c6456 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -8,7 +8,8 @@ "utils.rkt" "const.rkt") -(provide bitmap->hbitmap) +(provide bitmap->hbitmap + hbitmap->bitmap) (define (bitmap->hbitmap bm #:mask [mask-bm #f] @@ -56,4 +57,40 @@ (DeleteDC hdc) hbitmap))) +(define-cstruct _BITMAP + ([bmType _LONG] + [bmWidth _LONG] + [bmHeight _LONG] + [bmWidthBytes _LONG] + [bmPlanes _WORD] + [bmBitsPixel _WORD] + [bmBits _pointer])) +(define-gdi32 GetObjectW (_wfun _pointer _int _pointer -> (r : _int) + -> (when (zero? r) (failed 'GetObject)))) + +(define (hbitmap->bitmap hbitmap) + (let* ([bmi (let ([b (make-BITMAP 0 0 0 0 0 0 #f)]) + (GetObjectW hbitmap (ctype-sizeof _BITMAP) b) + b)] + [w (BITMAP-bmWidth bmi)] + [h (BITMAP-bmHeight bmi)] + [screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [old-hbitmap (SelectObject hdc hbitmap)] + [bm (make-object bitmap% w h (= 1 (BITMAP-bmBitsPixel bmi)) #t)]) + (ReleaseDC #f screen-hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create (send bm get-cairo-surface))]) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr s 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_set_source cr p) + (cairo_pattern_destroy p)) + (cairo_destroy cr) + (SelectObject hdc old-hbitmap) + (DeleteDC hdc) + bm))) From 04d103943aa8a183e92f1c64e01d55f3d2b84d52 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 Oct 2010 07:47:30 -0700 Subject: [PATCH 316/462] editor insert-image uses alpha by default original commit: 881c18295693db60c6006890d0f0b2d1e956abc3 --- collects/mred/private/wxme/editor.rkt | 4 ++-- collects/scribblings/gui/editor-intf.scrbl | 11 +++++++++-- .../scribblings/gui/image-snip-class.scrbl | 19 ++++++++++--------- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 0c10ec66..4cffb161 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -506,7 +506,7 @@ snip)) (def/public (insert-image [(make-or-false path-string?) [filename #f]] - [symbol? [type 'unknown]] + [image-type? [type 'unknown/alpha]] [any? [relative? #f]] [any? [inline-img? #t]]) (let ([filename (or filename @@ -518,7 +518,7 @@ (insert snip))))) (def/public (on-new-image-snip [path-string? filename] - [symbol? type] + [image-type? type] [any? relative?] [any? inline-img?]) (make-object image-snip% filename type relative? inline-img?)) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 4720f272..8a75d461 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -959,7 +959,11 @@ The @scheme[show-errors?] argument is no longer used. @defmethod[(insert-image [filename (or/c path-string? #f) #f] - [type (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown] + [type (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict) + 'unknown/alpha] [relative-path? any/c #f] [inline? any/c #t]) void?]{ @@ -1521,7 +1525,10 @@ Creates a @scheme[editor-snip%] with either a sub-editor from @defmethod[(on-new-image-snip [filename path?] - [kind (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)] + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)] [relative-path? any/c] [inline? any/c]) (is-a?/c image-snip%)]{ diff --git a/collects/scribblings/gui/image-snip-class.scrbl b/collects/scribblings/gui/image-snip-class.scrbl index 5d34edf3..aa45b9c0 100644 --- a/collects/scribblings/gui/image-snip-class.scrbl +++ b/collects/scribblings/gui/image-snip-class.scrbl @@ -9,9 +9,9 @@ An @scheme[image-snip%] is a snip that can display bitmap images @defconstructor*/make[(([filename (or/c path-string? false/c) #f] - [kind (one-of/c 'unknown 'unknown/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha 'xbm 'xpm 'bmp 'pict) 'unknown] [relative-path? any/c #f] [inline? any/c #t]) @@ -95,9 +95,10 @@ relative to the owning editor's path}] } @defmethod[(get-filetype) - (one-of/c 'unknown 'unknwon/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask 'xbm 'xpm 'bmp 'pict)]{ + (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)]{ Returns the kind used to load the currently loaded, non-inlined file, or @scheme['unknown] if a file is not loaded or if a file was loaded @@ -106,9 +107,9 @@ Returns the kind used to load the currently loaded, non-inlined file, } @defmethod[(load-file [filename (or/c path-string? false/c)] - [kind (one-of/c 'unknown 'unknown/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha 'xbm 'xpm 'bmp 'pict) 'unknown] [relative-path? any/c #f] [inline? any/c #t]) From b0f4d2f824c655a7a4fcedf3f8a4771e726002ad Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 Oct 2010 15:39:42 -0700 Subject: [PATCH 317/462] improve protection against multiple instantiation original commit: bcbe42f4ffb06877d01846f7e6bf4d959db07a63 --- collects/mred/private/wx/common/once.rkt | 14 ++++++++++++++ collects/mred/private/wx/common/queue.rkt | 12 ++---------- collects/mred/private/wx/common/utils.rkt | 3 ++- 3 files changed, 18 insertions(+), 11 deletions(-) create mode 100644 collects/mred/private/wx/common/once.rkt diff --git a/collects/mred/private/wx/common/once.rkt b/collects/mred/private/wx/common/once.rkt new file mode 100644 index 00000000..c0e49a64 --- /dev/null +++ b/collects/mred/private/wx/common/once.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require ffi/unsafe) + +(provide scheme_register_process_global) + +;; This module must be instantiated only once: + +(define scheme_register_process_global + (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer))) + +(let ([v (scheme_register_process_global "GRacket-support-initialized" + (cast 1 _scheme _pointer))]) + (when v + (error "cannot instantiate `racket/gui/base' a second time in the same process"))) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 5f717ea3..042a9281 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -5,7 +5,8 @@ racket/class "rbtree.rkt" "../../lock.rkt" - "handlers.rkt") + "handlers.rkt" + "once.rkt") (provide queue-evt set-check-queue! @@ -54,15 +55,6 @@ scheme_register_process_global) -;; ------------------------------------------------------------ -;; This module must be instantiated only once: - -(define-mz scheme_register_process_global (_fun _string _pointer -> _pointer)) -(let ([v (scheme_register_process_global "GRacket-support-initialized" - (cast 1 _scheme _pointer))]) - (when v - (error "cannot start GRacket a second time in the same process"))) - ;; ------------------------------------------------------------ ;; Create a Scheme evt that is ready when a queue is nonempty diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 5e7e4f02..1d9948dc 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe - ffi/unsafe/define) + ffi/unsafe/define + "once.rkt") (provide define-mz) From 0b65316bdf188b1b87a1e59c052499c4733d381d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Oct 2010 19:01:27 -0600 Subject: [PATCH 318/462] improve runtime-path support for building stand-alone gui exes original commit: 75a6bfe119d97ef81a28626bebe2b33799d41c06 --- collects/mred/private/wx/cocoa/tab-panel.rkt | 31 +++++++++++--------- collects/mred/private/wx/platform.rkt | 2 +- 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 68e29eab..dec99d7c 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -1,21 +1,24 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc - "../../syntax.rkt" - "types.rkt" - "utils.rkt" - "window.rkt" - "panel.rkt" - "../common/event.rkt" - "../common/procs.rkt") -(unsafe!) -(objc-unsafe!) +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + racket/runtime-path + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "panel.rkt" + "../common/event.rkt" + "../common/procs.rkt" + (for-syntax racket/base)) (provide tab-panel%) +(define-runtime-path psm-tab-bar-dir + '(so "PSMTabBarControl.framework")) + ;; Load PSMTabBarControl: -(void (ffi-lib "PSMTabBarControl.framework/PSMTabBarControl")) +(void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))) (define NSNoTabsNoBorder 6) (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 448aa92c..735172bd 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -2,7 +2,7 @@ (require scheme/runtime-path (for-syntax scheme/base)) (provide (all-defined-out)) -(define-runtime-path platform-lib +(define-runtime-module-path platform-lib (let ([gtk-lib '(lib "mred/private/wx/gtk/platform.rkt")]) (case (system-type) From 31a364e8927b622a8d096007a3b76f0cae6708e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Oct 2010 20:11:12 -0600 Subject: [PATCH 319/462] ppc cocoa original commit: 2cebc60eca44c78a441f89a825dd1eb3d60db7d7 --- collects/mred/private/wx/cocoa/canvas.rkt | 15 +++++++++++---- collects/mred/private/wx/cocoa/utils.rkt | 7 ++++++- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 2e50cc5c..704c0469 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -564,10 +564,17 @@ [(scroller val) (when scroller (set-scroller-page! scroller val) - (tellv (scroller-cocoa scroller) setKnobProportion: - #:type _CGFloat (max (min 1.0 (/ val - (+ val (exact->inexact (scroller-range scroller))))) - 0.0)))] + (let ([proportion + (max (min 1.0 (/ val + (+ val (exact->inexact (scroller-range scroller))))) + 0.0)]) + (if old-cocoa? + (tellv (scroller-cocoa scroller) + setFloatValue: #:type _float (tell #:type _float (scroller-cocoa scroller) + floatValue) + knobProportion: #:type _CGFloat proportion) + (tellv (scroller-cocoa scroller) setKnobProportion: + #:type _CGFloat proportion))))] [(scroller) (if scroller (scroller-page scroller) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index bc40b320..d6f50c12 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -18,7 +18,8 @@ with-autorelease clean-menu-label ->wxb - ->wx) + ->wx + old-cocoa?) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) @@ -69,3 +70,7 @@ (define (->wx wxb) (and wxb (weak-box-value wxb))) + +;; FIXME: need a better test: +(define old-cocoa? (equal? (path->string (system-library-subpath #f)) + "ppc-macosx")) From 4dfe6826a00adc5950ad021d971e12258966eff2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 24 Oct 2010 12:12:06 -0600 Subject: [PATCH 320/462] cocoa ppc repairs original commit: f57961fba436e059877ef8234930f54bd58dff60 --- collects/mred/private/wx/cocoa/window.rkt | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 3ff8328f..1ff12848 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -655,11 +655,12 @@ (define/public (screen-to-client xb yb) (let ([p (tell #:type _NSPoint (get-cocoa-content) - convertPointFromBase: #:type _NSPoint + convertPoint: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-window) convertScreenToBase: #:type _NSPoint (make-NSPoint (unbox xb) - (send (get-wx-window) flip-screen (unbox yb)))))]) + (send (get-wx-window) flip-screen (unbox yb)))) + fromView: #f)]) (set-box! xb (inexact->exact (floor (NSPoint-x p)))) (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) @@ -668,8 +669,9 @@ convertBaseToScreen: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-content) - convertPointToBase: #:type _NSPoint - (make-NSPoint (unbox xb) (flip-client (unbox yb)))))]) + convertPoint: #:type _NSPoint + (make-NSPoint (unbox xb) (flip-client (unbox yb))) + toView: #f))]) (let ([new-y (if flip-y? (send (get-wx-window) flip-screen (NSPoint-y p)) (NSPoint-y p))]) From daac40cc62f3fb37808b431bc997f17194b7c88c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 24 Oct 2010 11:17:45 -0600 Subject: [PATCH 321/462] cocoa: fix startup -psn_ and file handling original commit: a7426c1c2744dc71a8738e3c20bafcc8c0b2d115 --- collects/mred/private/app.rkt | 51 +++++++++++++------ collects/mred/private/wx/common/handlers.rkt | 12 +++-- .../scribblings/gui/system-menu-funcs.scrbl | 4 +- 3 files changed, 47 insertions(+), 20 deletions(-) diff --git a/collects/mred/private/app.rkt b/collects/mred/private/app.rkt index 67948560..c546ae87 100644 --- a/collects/mred/private/app.rkt +++ b/collects/mred/private/app.rkt @@ -1,6 +1,6 @@ -(module app mzscheme - (require mzlib/class - (prefix wx: "kernel.ss") +(module app racket/base + (require racket/class + (prefix-in wx: "kernel.ss") "lock.ss" "helper.ss" "wx.ss" @@ -50,7 +50,7 @@ (set! running-quit? #f)))))))))))]) (wx:application-quit-handler (make-app-handler f f))) - (define (set-handler! who proc param arity result-filter) + (define (set-handler! who proc param arity result-filter post-set) (when proc (unless (and (procedure? proc) (procedure-arity-includes? proc arity)) @@ -59,13 +59,14 @@ proc))) (let ([e (wx:current-eventspace)]) (when (wx:main-eventspace? e) - (param (make-app-handler + (param (make-app-handler (lambda args (parameterize ([wx:current-eventspace e]) (wx:queue-callback (lambda () (result-filter (apply proc args))) wx:middle-queue-key))) - proc))))) + proc)) + (post-set)))) (define application-preferences-handler (case-lambda @@ -75,7 +76,8 @@ (set-handler! 'application-preferences-handler proc wx:application-pref-handler 0 - values)])) + values + void)])) (define application-about-handler (case-lambda @@ -86,7 +88,8 @@ (set-handler! 'application-about-handler proc wx:application-about-handler 0 - values)])) + values + void)])) (define application-quit-handler (case-lambda @@ -97,18 +100,33 @@ (set-handler! 'application-quit-handler proc wx:application-quit-handler 0 - (lambda (v) (unless v (wx:cancel-quit)) v))])) + (lambda (v) (unless v (wx:cancel-quit)) v) + void)])) + + (define saved-files null) (define default-application-file-handler (entry-point (lambda (f) (let ([af (weak-box-value active-main-frame)]) - (when af - (queue-window-callback - af - (entry-point - (lambda () (when (send af accept-drag?) - (send af on-drop-file f)))))))))) + (if af + (queue-window-callback + af + (entry-point + (lambda () (if (send af accept-drag?) + (send af on-drop-file f) + (set! saved-files (cons f saved-files)))))) + (set! saved-files (cons f saved-files))))))) + + (define (requeue-saved-files) + (as-entry + (lambda () + (for-each (lambda (f) + (wx:queue-callback (lambda () + ((wx:application-file-handler) f)) + wx:middle-queue-key)) + (reverse saved-files)) + (set! saved-files null)))) (define (install-defh) (wx:application-file-handler (make-app-handler @@ -129,7 +147,8 @@ (set-handler! 'application-file-handler proc wx:application-file-handler 1 - values))])) + values + requeue-saved-files))])) (define (current-eventspace-has-standard-menus?) diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt index e8048f0f..9fad1616 100644 --- a/collects/mred/private/wx/common/handlers.rkt +++ b/collects/mred/private/wx/common/handlers.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide application-file-handler application-quit-handler @@ -7,10 +7,16 @@ nothing-application-pref-handler) -(define afh void) +(define saved-files null) +(define afh (lambda (f) + (set! saved-files (cons f saved-files)))) (define application-file-handler (case-lambda - [(proc) (set! afh proc)] + [(proc) + (set! afh proc) + (let ([sf saved-files]) + (set! saved-files null) + (for-each proc (reverse sf)))] [() afh])) (define aqh void) diff --git a/collects/scribblings/gui/system-menu-funcs.scrbl b/collects/scribblings/gui/system-menu-funcs.scrbl index 43904445..5051b9e4 100644 --- a/collects/scribblings/gui/system-menu-funcs.scrbl +++ b/collects/scribblings/gui/system-menu-funcs.scrbl @@ -113,7 +113,9 @@ When the current eventspace is the initial eventspace, this procedure The default handler queues a callback to the @method[window<%> on-drop-file] method of the most-recently activated frame in the main eventspace (see @scheme[get-top-level-edit-target-window]), if - drag-and-drop is enabled for that frame. + drag-and-drop is enabled for that frame. Otherwise, it saves + the filename and re-queues the handler event when the application + file handler is later changed. When the application is @italic{not} running and user double-clicks an application-handled file or drags a file onto the application's icon, From eedeeae1561a2cbadcdc8eb0e28c77d7d0c666df Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 24 Oct 2010 14:39:13 -0600 Subject: [PATCH 322/462] define-runtime-module-path-index and racket/gui/dynamic fixes original commit: dee93e625984f3f92cb699a4e131eb34aee94874 --- collects/mred/private/wx/platform.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 735172bd..8ecb9b16 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -1,8 +1,8 @@ -#lang scheme/base -(require scheme/runtime-path (for-syntax scheme/base)) +#lang racket/base +(require racket/runtime-path (for-syntax racket/base)) (provide (all-defined-out)) -(define-runtime-module-path platform-lib +(define-runtime-module-path-index platform-lib (let ([gtk-lib '(lib "mred/private/wx/gtk/platform.rkt")]) (case (system-type) From 53cf23d37875c636472914fa1b9224841980e06d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 25 Oct 2010 09:16:32 -0600 Subject: [PATCH 323/462] level-2 finalization from ffi/unsafe and late-weak references original commit: d2275f41794e1fe6b5e4a229a2afe08572efb111 --- collects/mred/private/wx/cocoa/list-box.rkt | 2 +- collects/tests/gracket/mem.rkt | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index f5bffb68..8163794e 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -30,7 +30,7 @@ (tell (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString (if wx (send wx get-row row) "???"))] - [font (send wx get-cell-font)]) + [font (and wx (send wx get-cell-font))]) (when font (tellv c setFont: font)) c) diff --git a/collects/tests/gracket/mem.rkt b/collects/tests/gracket/mem.rkt index 7e3603ee..ae8d663e 100644 --- a/collects/tests/gracket/mem.rkt +++ b/collects/tests/gracket/mem.rkt @@ -4,7 +4,7 @@ (define source-dir (current-load-relative-directory)) -(define num-times 8) +(define num-times 80) (define num-threads 3) (define dump-stats? #f) @@ -152,6 +152,7 @@ (when (and edit? insert?) (let ([e edit]) + (send e begin-edit-sequence) (when load-file? (send e load-file (build-path source-dir "mem.ss"))) (let loop ([i 20]) @@ -163,7 +164,8 @@ (send e insert s)) (send e insert #\newline) (send e insert "done") - (send e set-modified #f))) + (send e set-modified #f) + (send e end-edit-sequence))) (when menus? (let ([f (remember tag (make-object frame% "MB Frame 0"))]) From aee9c4da2570ed645b3bd52d210aee80c9aa9f34 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 25 Oct 2010 18:22:30 -0600 Subject: [PATCH 324/462] some fixes prompted by the test suite original commit: 4f2e59e7a654c9724d546f619589ca68cc334d59 --- collects/mred/private/wx/cocoa/canvas.rkt | 29 ++++++--- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 12 ++-- collects/mred/private/wx/cocoa/gauge.rkt | 8 ++- collects/mred/private/wx/cocoa/list-box.rkt | 5 +- collects/mred/private/wx/cocoa/menu.rkt | 3 +- collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/queue.rkt | 1 + collects/mred/private/wx/cocoa/radio-box.rkt | 10 +-- collects/mred/private/wx/cocoa/utils.rkt | 21 +++++-- .../mred/private/wx/common/backing-dc.rkt | 2 + collects/mred/private/wx/common/queue.rkt | 26 +++++--- collects/mred/private/wx/common/timer.rkt | 11 +++- collects/mred/private/wx/gtk/canvas.rkt | 26 +++++--- collects/mred/private/wx/gtk/frame.rkt | 17 +++++- collects/mred/private/wx/gtk/list-box.rkt | 9 +++ collects/mred/private/wx/gtk/menu.rkt | 2 +- collects/mred/private/wx/win32/list-box.rkt | 4 +- collects/mred/private/wxitem.rkt | 25 ++++---- collects/mred/private/wxlitem.rkt | 32 ++++++---- collects/mred/private/wxpanel.rkt | 34 ++++++----- collects/tests/gracket/dc.rktl | 61 ++++++++++++------- collects/tests/gracket/paramz.rktl | 12 ++-- 23 files changed, 228 insertions(+), 126 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 704c0469..638e1c56 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -331,9 +331,12 @@ (if (or is-combo? (not (memq 'gl style))) (tell (tell (if is-combo? MyComboBox MyView) alloc) initWithFrame: #:type _NSRect r) - (tell (tell MyGLView alloc) - initWithFrame: #:type _NSRect r - pixelFormat: (gl-config->pixel-format gl-config)))))) + (let ([pf (gl-config->pixel-format gl-config)]) + (begin0 + (tell (tell MyGLView alloc) + initWithFrame: #:type _NSRect r + pixelFormat: pf) + (tellv pf release))))))) (tell #:type _void cocoa addSubview: content-cocoa) (set-ivar! content-cocoa wxb (->wxb this)) @@ -462,12 +465,12 @@ (scroll-page h-scroller h-page) (scroll-pos h-scroller h-pos) (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) (scroll-range v-scroller v-len) (scroll-page v-scroller v-page) (scroll-pos v-scroller v-pos) (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) (define/override (reset-dc-for-autoscroll) (fix-dc)) @@ -484,12 +487,20 @@ (define/public (set-scroll-pos which v) (update which scroll-pos v)) + (define/private (guard-scroll which v) + (if (is-auto-scroll?) + 0 + v)) + (define/public (get-scroll-page which) - (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))) (define/public (get-scroll-range which) - (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))) (define/public (get-scroll-pos which) - (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))) (define v-scroller (and vscroll-ok? @@ -703,7 +714,7 @@ (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/override (get-virtual-h-pos) (scroll-pos h-scroller)) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index b80f27d6..1974622d 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -58,7 +58,7 @@ [time-stamp (current-milliseconds)]))) (define/public (set-selection i) - (tell (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) + (tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) (define/public (get-selection) (tell #:type _NSInteger (get-cocoa) indexOfSelectedItem)) (define/public (number) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 6f91dd18..4370a2ec 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -121,7 +121,7 @@ (inherit get-cocoa get-parent get-eventspace pre-on-char pre-on-event - get-x get-y + get-x on-new-child) (super-new [parent parent] @@ -168,7 +168,8 @@ (atomically (let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")]) (tellv cocoa setToolbar: tb) - (tellv tb setVisible: #:type _BOOL #f)))) + (tellv tb setVisible: #:type _BOOL #f) + (tellv tb release)))) (move -11111 (if (= y -11111) 0 y)) @@ -380,6 +381,9 @@ (define/override (flip y h) (flip-screen (+ y h))) + (define/override (get-y) + (- (super get-y) (if caption? 22 0))) + (define/override (set-size x y w h) (unless (and (= x -1) (= y -1)) (move x y)) @@ -399,10 +403,6 @@ (NSPoint-x (NSRect-origin f))) ;; keep current y position: (- (NSPoint-y (NSRect-origin f)) - ;; we have to subtract add the titlebar height, for some reason: - (if caption? - (- 22) - 0) (- h (NSSize-height (NSRect-size f))))) (make-NSSize w h)) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index d4eeb201..1dfa3fce 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -32,7 +32,10 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (as-objc-allocation + [cocoa (let ([cocoa (values ; as-objc-allocation + ;; We're leaving guages for now. There's some problem + ;; releasing gauges through a finalizer. My guess is that + ;; it has something to do with animation in a separate thread. (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) @@ -60,7 +63,8 @@ (define/public (get-range) (inexact->exact (floor (tell #:type _double cocoa maxValue)))) (define/public (set-range rng) - (tellv cocoa setMaxValue: #:type _double* rng)) + (tellv cocoa setMaxValue: #:type _double* rng) + (tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue)))) (define/public (set-value v) (tellv cocoa setDoubleValue: #:type _double* v)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 8163794e..40f635e5 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -92,7 +92,8 @@ (tellv cocoa setDocumentView: content-cocoa) (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) (tellv content-cocoa setHeaderView: #f) - (unless (eq? kind 'single) + (define allow-multi? (not (eq? kind 'single))) + (when allow-multi? (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) @@ -174,7 +175,7 @@ (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) (tellv content-cocoa selectRowIndexes: index - byExtendingSelection: #:type _BOOL extend?)))) + byExtendingSelection: #:type _BOOL (and extend? allow-multi?))))) (tellv content-cocoa deselectRow: #:type _NSInteger i))) (define/public (set-selection i) (select i #t #f)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 422554f9..4cc2ca0a 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -115,7 +115,8 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) - (def/public-unimplemented set-help-string) + (define/public (set-help-string m s) (void)) + (def/public-unimplemented number) (define/private (find-pos item) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 46047d2c..b7903746 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -82,5 +82,5 @@ (as-objc-allocation (tell (tell MyPanelView alloc) initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) - (make-NSSize w h))))] + (make-NSSize (max 1 w) (max 1 h)))))] [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index a5b02f24..1dcc21fc 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -214,6 +214,7 @@ ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) + (clean-up-deleted) (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (when (and events-suspended? wait?) (set! was-menu-bar #f) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 3a0e9b57..be329cb6 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -117,11 +117,13 @@ 0 (set-focus))) + (define/private (get-button i) + (tell (get-cocoa) + cellAtRow: #:type _NSUInteger (if horiz? 0 i) + column: #:type _NSUInteger (if horiz? i 0))) + (define/public (enable-button i on?) - (tellv (tell (get-cocoa) - cellAtRow: #:type _NSUInteger (if horiz? 0 i) - column: #:type _NSUInteger (if horiz? i 0)) - setEnabled: #:type _BOOL on?)) + (tellv (get-button i) setEnabled: #:type _BOOL on?)) (define/public (set-selection i) (if (= i -1) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index d6f50c12..b1553187 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -3,7 +3,8 @@ ffi/unsafe ffi/unsafe/alloc ffi/unsafe/define - "../common/utils.rkt") + "../common/utils.rkt" + "../../lock.rkt") (provide cocoa-lib cf-lib @@ -14,6 +15,7 @@ define-mz as-objc-allocation as-objc-allocation-with-retain + clean-up-deleted retain release with-autorelease clean-menu-label @@ -31,8 +33,19 @@ (define-ffi-definer define-appserv appserv-lib) (define-ffi-definer define-appkit appkit-lib) -(define (objc-delete v) - (tellv v release)) +(define delete-me null) + +(define (objc-delete o) + (atomically + (set! delete-me (cons o delete-me)))) + +(define (clean-up-deleted) + ;; called outside the event loop to actually delete objects + ;; that might otherwise be in use during a callback + (for ([o (in-list (begin0 + delete-me + (set! delete-me null)))]) + (tellv o release))) (define objc-allocator (allocator objc-delete)) @@ -59,7 +72,7 @@ (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (begin0 (thunk) - (release pool)))) + (tellv pool release)))) (define (clean-menu-label str) (regexp-replace* #rx"&(.)" str "\\1")) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 7b848a55..1c4f9669 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -42,6 +42,8 @@ (super-new) + (define/override (ok?) #t) + ;; Override this method to get the right size (define/public (get-backing-size xb yb) (set-box! xb 1) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 042a9281..7882a650 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -383,6 +383,10 @@ [(and (eq? evt 'wait) (not handler?)) #t] + ;; `yield' is supposed to return immediately if the + ;; event is already ready: + [(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v))))) + => (lambda (v) (car v))] [handler? (sync (if (eq? evt 'wait) (wrap-evt e (lambda (_) #t)) @@ -411,18 +415,24 @@ (eq? e main-eventspace)) (define (queue-callback thunk [high? #t]) - (queue-event (current-eventspace) thunk (cond - [(not high?) 'lo] - [(eq? high? middle-queue-key) 'med] - [else 'hi]))) + (let ([es (current-eventspace)]) + (when (eventspace-shutdown? es) + (error 'queue-callback "eventspace is shutdown: ~e" es)) + (queue-event es thunk (cond + [(not high?) 'lo] + [(eq? high? middle-queue-key) 'med] + [else 'hi])))) (define middle-queue-key (gensym 'middle)) -(define (add-timer-callback cb) - (queue-event (current-eventspace) cb 'timer-add)) -(define (remove-timer-callback cb) - (queue-event (current-eventspace) cb 'timer-remove)) +(define (add-timer-callback cb es) + ;; in atomic mode + (queue-event es cb 'timer-add)) +(define (remove-timer-callback cb es) + ;; in atomic mode + (unless (eventspace-shutdown? es) + (queue-event es cb 'timer-remove))) (define (register-frame-shown f on?) (queue-event (current-eventspace) f (if on? diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt index 2f6301fd..0a950e86 100644 --- a/collects/mred/private/wx/common/timer.rkt +++ b/collects/mred/private/wx/common/timer.rkt @@ -15,11 +15,18 @@ (define current-interval ival) (define current-once? (and just-once? #t)) (define cb #f) + (define es (current-eventspace)) + + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) + (def/public (interval) current-interval) (define/private (do-start msec once?) (as-entry (lambda () (do-stop) + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) (set! current-interval msec) (set! current-once? (and once? #t)) (letrec ([new-cb @@ -33,14 +40,14 @@ (when (eq? cb new-cb) (do-start msec #f))))))))]) (set! cb new-cb) - (add-timer-callback new-cb))))) + (add-timer-callback new-cb es))))) (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) (do-start msec once?)) (define/private (do-stop) (as-entry (lambda () (when cb - (remove-timer-callback cb) + (remove-timer-callback cb es) (set! cb #f))))) (def/public (stop) (do-stop)) (def/public (notify) (notify-cb) (void)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 52a94297..977ea3a5 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -476,14 +476,20 @@ (gtk_adjustment_set_value adj v)))))) (define/public (get-scroll-page which) - (->long (dispatch which gtk_adjustment_get_page_size 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_page_size 0)))) (define/public (get-scroll-range which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_upper adj) - (gtk_adjustment_get_page_size adj))) - 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0)))) (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_value 0)))) (define clear-bg? (and (not (memq 'transparent style)) @@ -541,12 +547,12 @@ (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/override (get-virtual-h-pos) - (gtk_adjustment_get_value hscroll-adj)) - (define/override (get-virtual-v-pos) - (gtk_adjustment_get_value vscroll-adj)) + (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj)))) + (define/override (get-virtual-v-pos) + (inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj)))) (define/public (set-resize-corner on?) (void)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c9be2bc2..c76c3de6 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -53,6 +53,9 @@ (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) +(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) + (define-cstruct _GdkGeometry ([min_width _int] [min_height _int] [max_width _int] @@ -429,6 +432,7 @@ (send in-window enter-window))) (define maximized? #f) + (define is-iconized? #f) (define/public (is-maximized?) maximized?) @@ -437,11 +441,18 @@ (define/public (on-window-state changed value) (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED)) - (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))) + (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))) + (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED)) + (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED))))) - (def/public-unimplemented iconized?) + (define/public (iconized?) + is-iconized?) + (define/public (iconize on?) + (if on? + (gtk_window_iconify gtk) + (gtk_window_deiconify gtk))) + (def/public-unimplemented get-menu-bar) - (def/public-unimplemented iconize) (define/public (set-title s) (set! saved-title s) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 291ea5c3..3b18357a 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -25,6 +25,9 @@ (define _GtkCellRenderer (_cpointer 'GtkCellRenderer)) (define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn) +(define GTK_SELECTION_SINGLE 1) +(define GTK_SELECTION_MULTIPLE 3) + (define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) @@ -38,6 +41,7 @@ (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void)) (define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) (define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) (define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) @@ -112,6 +116,11 @@ (define selection (gtk_tree_view_get_selection client-gtk)) + (gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended) + (eq? kind 'multiple)) + GTK_SELECTION_MULTIPLE + GTK_SELECTION_SINGLE)) + (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk selection)] diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 42cd4e07..a4207ffa 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -220,7 +220,7 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) - (def/public-unimplemented set-help-string) + (define/public (set-help-string m s) (void)) (define/public (number) (length items)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index ba12082f..c7ea846c 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -69,8 +69,8 @@ (if (memq 'hscroll style) WS_HSCROLL 0) (cond ;; Win32 sense of "multiple" and "extended" is backwards - [(memq 'extended style) LBS_MULTIPLESEL] - [(memq 'multiple style) LBS_EXTENDEDSEL] + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] [else 0])) 0 0 0 0 (send parent get-client-hwnd) diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt index e3b1dd62..0f84b39c 100644 --- a/collects/mred/private/wxitem.rkt +++ b/collects/mred/private/wxitem.rkt @@ -1,8 +1,8 @@ -(module wxitem mzscheme +(module wxitem racket/base (require mzlib/class mzlib/class100 mzlib/etc - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "helper.ss" "const.ss" @@ -10,12 +10,12 @@ "check.ss" "wxwindow.ss") - (provide (protect make-item% - make-control% - make-simple-control% - wx-button% - wx-check-box% - wx-message%)) + (provide (protect-out make-item% + make-control% + make-simple-control% + wx-button% + wx-check-box% + wx-message%)) ;; make-item%: creates items which are suitable for placing into ;; containers. @@ -61,8 +61,7 @@ (super set-size x y width height)))]) (public - [is-enabled? - (lambda () enabled?)]) + [is-enabled? (lambda () enabled?)]) (private-field ;; Store minimum size of item. @@ -207,10 +206,8 @@ (apply super-init args) (send (get-parent) set-item-cursor 0 0)))) - (define (make-simple-control% item%) - (make-control% item% - const-default-x-margin const-default-y-margin - #f #f)) + (define (make-simple-control% item% [x-m const-default-x-margin] [y-m const-default-y-margin]) + (make-control% item% x-m y-m #f #f)) (define wx-button% (make-window-glue% (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index ea947168..9b14bcac 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -55,12 +55,13 @@ ;; ---------------------------------------- (define wx-label-panel% - (class wx-horizontal-panel% + (class wx-control-horizontal-panel% (init proxy parent label style font halign valign) (inherit area-parent) (define c #f) (define/override (enable on?) (if c (send c enable on?) (void))) + (define/override (is-enabled?) (if c (send c is-enabled?) #t)) (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t)) (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) @@ -83,7 +84,7 @@ ;; ---------------------------------------- (define wx-internal-choice% - (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) + (class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font) (override [handles-key-code (lambda (x alpha? meta?) @@ -119,9 +120,7 @@ (define wx-internal-list-box% (make-window-glue% - (class100 (make-control% wx:list-box% - const-default-x-margin const-default-y-margin - #t #t) (parent cb label kind x y w h choices style font label-font) + (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font) (inherit get-first-item set-first-visible-item) (private @@ -194,7 +193,7 @@ (define wx-internal-radio-box% (make-window-glue% - (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) + (class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font) (inherit number orig-enable set-selection command) (override [enable @@ -233,10 +232,21 @@ major (filter-style style) font)) (set-c c #t #t) + (define enable-vector (make-vector (length choices) #t)) + (define/override enable (case-lambda [(on?) (super enable on?)] - [(i on?) (send c enable-button i on?)])) + [(i on?) + (when (< -1 i (vector-length enable-vector)) + (vector-set! enable-vector i on?) + (send c enable-button i on?))])) + + (define/override is-enabled? + (case-lambda + [() (super is-enabled?)] + [(which) (and (< -1 which (vector-length enable-vector)) + (vector-ref enable-vector which))])) (bounce c @@ -250,9 +260,7 @@ (define wx-internal-gauge% (make-window-glue% - (class100 (make-control% wx:gauge% - const-default-x-margin const-default-y-margin - #f #f) + (class100 (make-control% wx:gauge% 0 0 #f #f) (parent label range style font) (inherit get-client-size get-width get-height set-size stretchable-in-x stretchable-in-y set-min-height set-min-width @@ -324,9 +332,7 @@ (define wx-internal-slider% (make-window-glue% - (class100 (make-control% wx:slider% - const-default-x-margin const-default-y-margin - #f #f) + (class100 (make-control% wx:slider% 0 0 #f #f) (parent func label value min-val max-val style font) (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y get-client-size get-width get-height get-parent) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index 29bd3e8c..99e2017e 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -1,8 +1,8 @@ -(module wxpanel mzscheme +(module wxpanel racket/base (require mzlib/class mzlib/class100 mzlib/list - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "const.ss" "helper.ss" @@ -12,15 +12,16 @@ "wxitem.ss" "wxcontainer.ss") - (provide (protect wx-panel% - wx-vertical-panel% - wx-vertical-tab-panel% - wx-vertical-group-panel% - wx-horizontal-panel% - wx-pane% - wx-vertical-pane% - wx-horizontal-pane% - wx-grow-box-pane%)) + (provide (protect-out wx-panel% + wx-vertical-panel% + wx-vertical-tab-panel% + wx-vertical-group-panel% + wx-horizontal-panel% + wx-control-horizontal-panel% + wx-pane% + wx-vertical-pane% + wx-horizontal-pane% + wx-grow-box-pane%)) (define wx:windowless-panel% (class100 object% (prnt x y w h style label) @@ -61,8 +62,8 @@ 0 2)) - (define (wx-make-basic-panel% wx:panel% stretch?) - (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style label) + (define (wx-make-basic-panel% wx:panel% stretch? [x-m 0] [y-m 0]) + (class100* (wx-make-container% (make-item% wx:panel% x-m y-m stretch? stretch?)) (wx-basic-panel<%>) (parent style label) (inherit get-x get-y get-width get-height min-width min-height set-min-width set-min-height x-margin y-margin @@ -476,8 +477,8 @@ (sequence (apply super-init args)))) - (define (wx-make-panel% wx:panel%) - (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args + (define (wx-make-panel% wx:panel% [x-m 0] [y-m 0]) + (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t x-m y-m))) args (rename [super-on-visible on-visible] [super-on-active on-active]) (inherit get-children) @@ -724,15 +725,18 @@ (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) (define wx-panel% (wx-make-panel% wx:panel%)) + (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) (define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) (define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) + (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%)) (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) + (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%)) (define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) (define wx-grow-box-pane% diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 2ce39dbe..5e7d0f6f 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -20,7 +20,11 @@ (send-generic mdc (make-generic (object-interface mdc) m) . args) (error 'bad-dc "~a shouldn't succeed" `(send ,m ...)))) -(define (test-all mdc try) +(define (good m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + +(define (test-all mdc try try-ok) + (try 'erase) (try 'clear) (try 'draw-arc 0 0 10 10 0.1 0.2) (try 'draw-bitmap bm2 0 0) @@ -40,35 +44,46 @@ (try 'end-page) (try 'end-doc) - (try 'get-background) - (try 'get-brush) - (try 'get-clipping-region) - (try 'get-font) - (try 'get-pen) (try 'get-size) - (try 'get-text-background) - (try 'get-text-foreground) - (try 'get-text-mode) - (try 'set-background (make-object color% "Yellow")) - (try 'set-brush (make-object brush% "Yellow" 'solid)) - (try 'set-clipping-rect 0 0 10 10) - (try 'set-clipping-region (make-object region% mdc)) - (try 'set-font (make-object font% 12 'default 'normal 'normal)) - (try 'set-origin 0 0) - (try 'set-pen (make-object pen% "Yellow" 1 'solid)) - (try 'set-scale 2 2) - (try 'set-text-background (make-object color% "Yellow")) - (try 'set-text-foreground (make-object color% "Yellow")) - (try 'set-text-mode 'transparent) + (try-ok 'get-background) + (try-ok 'get-brush) + (try-ok 'get-clipping-region) + (try-ok 'get-font) + (try-ok 'get-pen) + (try-ok 'get-text-background) + (try-ok 'get-text-foreground) + (try-ok 'get-text-mode) + (try-ok 'get-alpha) + (try-ok 'get-scale) + (try-ok 'get-origin) + (try-ok 'get-rotation) + + (try-ok 'set-background (make-object color% "Yellow")) + (try-ok 'set-brush (make-object brush% "Yellow" 'solid)) + (try-ok 'set-clipping-rect 0 0 10 10) + (try-ok 'set-clipping-region (make-object region% mdc)) + (try-ok 'set-font (make-object font% 12 'default 'normal 'normal)) + (try-ok 'set-origin 0 0) + (try-ok 'set-pen (make-object pen% "Yellow" 1 'solid)) + (try-ok 'set-scale 2 2) + (try-ok 'set-alpha 0.75) + (try-ok 'set-text-background (make-object color% "Yellow")) + (try-ok 'set-text-foreground (make-object color% "Yellow")) + (try-ok 'set-text-mode 'transparent) + (try 'try-color (make-object color% "Yellow") (make-object color%))) (st #f mdc ok?) -(test-all mdc bad) +(test-all mdc bad good) (send mdc set-bitmap bm) -(test-all mdc (lambda (m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args))) + +(test-all mdc + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args))) (send mdc set-bitmap #f) diff --git a/collects/tests/gracket/paramz.rktl b/collects/tests/gracket/paramz.rktl index 2aef912e..36e7697a 100644 --- a/collects/tests/gracket/paramz.rktl +++ b/collects/tests/gracket/paramz.rktl @@ -34,7 +34,7 @@ (define d (make-object dialog% "hello")) (thread (lambda () - (sleep 1) + (sync (system-idle-evt)) (queue-callback (lambda () (set! v 11))) (send d show #f))) (queue-callback (lambda () (set! v 10))) @@ -56,15 +56,17 @@ (st #f d is-shown?) (let ([t (thread (lambda () - (send d show #t)))]) - (let loop () (unless (send d is-shown?) (loop))) + (send d show #t)))]) + (let loop () (unless (send d is-shown?) (sleep) (loop))) (st #t d is-shown?) (thread-suspend t) (stv d show #f) + (st #f d is-shown?) (let ([t2 (thread (lambda () (send d show #t)))]) - (sleep 0.1) + (yield (system-idle-evt)) + (st #t d is-shown?) (thread-resume t) - (sleep 0.1) + (yield (system-idle-evt)) (st #t d is-shown?) (test #t 'thread2 (thread-running? t2)) (stv d show #f) From a7d96b37cec76d07601cfd9d1eb105bde98c1c9b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 16:06:19 -0600 Subject: [PATCH 325/462] gtk: swap alt and meta reporting original commit: 2c775657212c171d14155a7f62aafa11bc18ab81 --- collects/mred/private/wx/gtk/window.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index bfa81ac8..0aa30e25 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -197,8 +197,8 @@ [key-code key-code] [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)] + [meta-down (bit? modifiers GDK_MOD1_MASK)] + [alt-down (bit? modifiers GDK_META_MASK)] [x 0] [y 0] [time-stamp (if scroll? From a8ff7273c0e67007b448ff0f87aaef4e0b974816 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 09:47:36 -0600 Subject: [PATCH 326/462] cocoa: fix menu set-label original commit: 99266dcdcf8a14de3cb916bf248958e9964b6f1c --- collects/mred/private/wx/cocoa/menu-item.rkt | 54 ++++++++++---------- collects/mred/private/wx/cocoa/menu.rkt | 16 +++--- 2 files changed, 36 insertions(+), 34 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 5495e00e..672a2b7c 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -1,15 +1,14 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "utils.rkt" "types.rkt" "const.rkt") -(unsafe!) -(objc-unsafe!) -(provide menu-item%) +(provide menu-item% + set-menu-item-shortcut) (import-class NSMenuItem) @@ -73,25 +72,28 @@ (tellv item setAction: #:type _SEL (if checkable? (selector selectedCheckable:) (selector selected:))) - (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) + (set-menu-item-shortcut item label) (release item)))) (super-new)) + +(define (set-menu-item-shortcut item label) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (when shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods))))) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 4cc2ca0a..7f9637eb 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -1,15 +1,14 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc (only-in scheme/list drop take) - ffi/objc "../common/event.rkt" "../../syntax.rkt" "utils.rkt" "types.rkt" - "window.rkt") -(unsafe!) -(objc-unsafe!) + "window.rkt" + "menu-item.rkt") (provide menu%) @@ -136,7 +135,8 @@ (define/public (set-label item label) (adjust item (lambda (item-cocoa) - (tellv item-cocoa setTitle: #:type _NSString (clean-menu-label label))) + (tellv item-cocoa setTitle: #:type _NSString (clean-menu-label (regexp-replace #rx"\t.*" label ""))) + (set-menu-item-shortcut item-cocoa label)) (lambda (mitem) (send (mitem-item mitem) set-label (clean-menu-label label))))) From 04623979f5c3501159282351cc6f2afd2324a08a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 15:58:00 -0600 Subject: [PATCH 327/462] misc fixes, especially cocoa original commit: bffff78aad36699025d498442f38214f0727ad5b --- collects/mred/private/wx/cocoa/frame.rkt | 17 ++++++++++++++--- collects/mred/private/wx/cocoa/queue.rkt | 15 ++++----------- collects/mred/private/wx/cocoa/tab-panel.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 1 + collects/mred/private/wx/common/clipboard.rkt | 15 +++++++++++++-- 5 files changed, 33 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 4370a2ec..5536d187 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -12,6 +12,7 @@ "cursor.rkt" "../../syntax.rkt" "../common/queue.rkt" + "../common/freeze.rkt" "../../lock.rkt") (provide frame% @@ -55,9 +56,17 @@ #f] [-a _void (windowDidResize: [_id notification]) (when wxb - (queue-window*-event wxb (lambda (wx) - (send wx on-size 0 0) - (send wx clean-up))))] + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () + (send wx on-size 0 0) + (send wx clean-up))) + ;; Live resize: + (constrained-reply (send wx get-eventspace) + (lambda () + (pre-event-sync #t) + (let loop () (when (yield) (loop)))) + (void)))))] [-a _void (windowDidMove: [_id notification]) (when wxb (queue-window*-event wxb (lambda (wx) @@ -248,6 +257,8 @@ (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) (and (tell #:type _BOOL win isVisible) + (or (not root-fake-frame) + (not (ptr-equal? win (send root-fake-frame get-cocoa)))) win)))))))]) (cond [next (tellv next makeKeyWindow)] diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 1dcc21fc..9e96c79b 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -47,7 +47,10 @@ (not (eq? (application-pref-handler) nothing-application-pref-handler)) (super-tell #:type _BOOL validateMenuItem: menuItem))] [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) - (queue-file-event (string->path filename))]) + (queue-file-event (string->path filename))] + [-a _void (applicationDidChangeScreenParameters: notification) + ;; Need to reset blit windows, since OS may move them incorrectly + (void)]) (tellv app finishLaunching) @@ -55,16 +58,6 @@ (tellv app setDelegate: app-delegate) (tellv app activateIgnoringOtherApps: #:type _BOOL #t) -#| -(import-class NSNotificationCenter) -(define-cocoa NSMenuDidBeginTrackingNotification _id) -(tellv (tell NSNotificationCenter defaultCenter) - addObserver: app-delegate - selector: #:type _SEL (selector trackingMenuNow:) - name: NSMenuDidBeginTrackingNotification - object: #f) -|# - ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index dec99d7c..d5f8a397 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -8,6 +8,7 @@ "utils.rkt" "window.rkt" "panel.rkt" + "queue.rkt" "../common/event.rkt" "../common/procs.rkt" (for-syntax racket/base)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 1ff12848..b937b47b 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -512,6 +512,7 @@ (define/public (set-size x y w h) (let ([x (if (= x -11111) (get-x) x)] [y (if (= y -11111) (get-y) y)]) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (make-NSSize w h))))) (define/public (move x y) diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt index caee9e65..af22c334 100644 --- a/collects/mred/private/wx/common/clipboard.rkt +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -27,6 +27,14 @@ (void)) (super-new)) +(define string-clipboard-client% + (class clipboard-client% + (init-field the-bytes) + (super-new) + (define/override (get-types) (list "TEXT")) + (define/override (get-data s) + (and (equal? s "TEXT") the-bytes)))) + (defclass clipboard% object% (init x-selection?) @@ -44,12 +52,15 @@ (send driver get-data type)) (def/public (get-clipboard-string [exact-integer? timestamp]) (send driver get-text-data)) - (def/public-unimplemented set-clipboard-string) - (def/public (set-clipboard-client [clipboard-client% c] [exact-integer? timestamp]) (send c set-client-eventspace (current-eventspace)) (send driver set-client c (send c get-types))) + (def/public (set-clipboard-string [string? str] + [exact-integer? timestamp]) + (set-clipboard-client (make-object string-clipboard-client% + (string->bytes/utf-8 str)) + timestamp)) (super-new)) From 33dd9054d36cde0f98d79cf23e0c1b6044c1d91b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 16:15:53 -0600 Subject: [PATCH 328/462] work around cocoa display-change issue original commit: 47c032ff34a102e7bf1e909483a24c29c0399b2f --- collects/mred/private/wx/cocoa/queue.rkt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9e96c79b..462052bf 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -58,6 +58,16 @@ (tellv app setDelegate: app-delegate) (tellv app activateIgnoringOtherApps: #:type _BOOL #t) +;; For some reason, nextEventMatchingMask:... gets stuck if the +;; display changes, and it doesn't even send the +;; `applicationDidChangeScreenParameters:' callback. Unstick +;; it by posting a dummy event, since we fortunately can receive +;; a callback via CGDisplayRegisterReconfigurationCallback(). +(define-appserv CGDisplayRegisterReconfigurationCallback + (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) +(define (on-screen-changed) (post-dummy-event)) +(CGDisplayRegisterReconfigurationCallback on-screen-changed #f) + ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up From 91b11153a1d73f28a619c78d9b12090ed54d6227 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 16:28:24 -0600 Subject: [PATCH 329/462] gtk: enable "really overwrite?" dialog for `put-file' original commit: 3abecbc95d4dae9ef36568dd1e8312a859bc09a5 --- collects/mred/private/wx/gtk/filedialog.rkt | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt index e25a0cd8..97034faa 100644 --- a/collects/mred/private/wx/gtk/filedialog.rkt +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -39,6 +39,8 @@ (_fun _GtkFileChooserDialog _path -> _void)) (define-gtk gtk_file_chooser_set_current_folder (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_do_overwrite_confirmation + (_fun _GtkFileChooserDialog _gboolean -> _void)) (define-gtk gtk_file_chooser_set_select_multiple (_fun _GtkFileChooserDialog _gboolean -> _void)) @@ -78,6 +80,8 @@ (gtk_file_chooser_set_current_name dlg filename)) (when directory (gtk_file_chooser_set_current_folder dlg directory)) + (when (eq? 'put type) + (gtk_file_chooser_set_do_overwrite_confirmation dlg #t)) (for ([f (in-list filters)]) (match f [(list name glob) @@ -85,15 +89,7 @@ (gtk_file_filter_set_name ff name) (gtk_file_filter_add_pattern ff glob) (gtk_file_chooser_add_filter dlg ff))])) - (define ans (and (eq? 'accept (show-dialog dlg - (lambda (v) - (or (not (eq? v 'accept)) - ;; FIXME: for get mode, probably should check file vs. - ;; directory name - (not (eq? type 'put)) - (not (file-exists? (gtk_file_chooser_get_filename dlg))) - ;; FIXME: need to ask "replace the file? here - #t)))) + (define ans (and (eq? 'accept (show-dialog dlg)) (if (eq? type 'multi) (gtk_file_chooser_get_filenames dlg) (gtk_file_chooser_get_filename dlg)))) From 5e6bcc8be3aa4ccd1328eab38697e64b8defd211 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Oct 2010 16:39:09 -0600 Subject: [PATCH 330/462] fix mistake cocoa screen notification original commit: 4f55d2270566c57dad2c4d35b558d1cf7cdb5c6e --- collects/mred/private/wx/cocoa/queue.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 462052bf..7d73a699 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -66,7 +66,8 @@ (define-appserv CGDisplayRegisterReconfigurationCallback (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) (define (on-screen-changed) (post-dummy-event)) -(CGDisplayRegisterReconfigurationCallback on-screen-changed #f) +(void + (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is From c14bee176f735cb203c25cda3481b9a7d85dcd3b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Oct 2010 05:23:18 -0600 Subject: [PATCH 331/462] clean up original commit: d7f1d12ea1c16d5ed062a8ac8fe2fe47db267f15 --- collects/framework/private/preferences.rkt | 28 +- collects/mred/mred-sig.rkt | 3 - collects/mred/mred.rkt | 3 - collects/mred/private/syntax.rkt | 300 +----------------- collects/mred/private/wx/cocoa/README.txt | 3 +- collects/mred/private/wx/cocoa/button.rkt | 17 +- collects/mred/private/wx/cocoa/canvas.rkt | 8 +- collects/mred/private/wx/cocoa/cg.rkt | 2 +- collects/mred/private/wx/cocoa/check-box.rkt | 13 +- collects/mred/private/wx/cocoa/choice.rkt | 13 +- collects/mred/private/wx/cocoa/clipboard.rkt | 11 +- .../mred/private/wx/cocoa/colordialog.rkt | 5 +- collects/mred/private/wx/cocoa/const.rkt | 2 +- collects/mred/private/wx/cocoa/cursor.rkt | 7 +- collects/mred/private/wx/cocoa/dc.rkt | 14 +- collects/mred/private/wx/cocoa/dialog.rkt | 7 +- collects/mred/private/wx/cocoa/filedialog.rkt | 3 +- collects/mred/private/wx/cocoa/finfo.rkt | 3 +- collects/mred/private/wx/cocoa/font.rkt | 3 +- collects/mred/private/wx/cocoa/frame.rkt | 9 +- collects/mred/private/wx/cocoa/gauge.rkt | 13 +- collects/mred/private/wx/cocoa/gc.rkt | 7 +- .../mred/private/wx/cocoa/group-panel.rkt | 13 +- collects/mred/private/wx/cocoa/image.rkt | 11 +- collects/mred/private/wx/cocoa/init.rkt | 2 +- collects/mred/private/wx/cocoa/item.rkt | 15 +- collects/mred/private/wx/cocoa/keycode.rkt | 2 +- collects/mred/private/wx/cocoa/list-box.rkt | 13 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 7 +- collects/mred/private/wx/cocoa/menu-item.rkt | 5 +- collects/mred/private/wx/cocoa/menu.rkt | 3 +- collects/mred/private/wx/cocoa/message.rkt | 15 +- collects/mred/private/wx/cocoa/panel.rkt | 15 +- collects/mred/private/wx/cocoa/platform.rkt | 5 +- collects/mred/private/wx/cocoa/pool.rkt | 5 +- collects/mred/private/wx/cocoa/printer-dc.rkt | 20 +- collects/mred/private/wx/cocoa/procs.rkt | 76 ++--- collects/mred/private/wx/cocoa/queue.rkt | 32 +- collects/mred/private/wx/cocoa/radio-box.rkt | 13 +- collects/mred/private/wx/cocoa/slider.rkt | 13 +- collects/mred/private/wx/cocoa/sound.rkt | 3 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 3 +- collects/mred/private/wx/cocoa/types.rkt | 27 +- collects/mred/private/wx/cocoa/utils.rkt | 35 +- collects/mred/private/wx/cocoa/window.rkt | 33 +- .../mred/private/wx/common/backing-dc.rkt | 42 +-- .../mred/private/wx/common/canvas-mixin.rkt | 7 +- collects/mred/private/wx/common/clipboard.rkt | 9 +- .../mred/private/wx/common/default-procs.rkt | 2 +- collects/mred/private/wx/common/delay.rkt | 5 +- collects/mred/private/wx/common/dialog.rkt | 2 +- collects/mred/private/wx/common/event.rkt | 4 +- collects/mred/private/wx/common/freeze.rkt | 7 +- collects/mred/private/wx/common/handlers.rkt | 13 +- collects/mred/private/wx/common/local.rkt | 6 +- collects/mred/private/wx/common/once.rkt | 2 +- collects/mred/private/wx/common/procs.rkt | 2 +- collects/mred/private/wx/common/queue.rkt | 77 ++--- collects/mred/private/wx/common/rbtree.rkt | 6 +- collects/mred/private/wx/common/timer.rkt | 4 +- collects/mred/private/wx/common/utils.rkt | 2 +- collects/mred/private/wx/gtk/button.rkt | 12 +- collects/mred/private/wx/gtk/canvas.rkt | 7 +- collects/mred/private/wx/gtk/check-box.rkt | 10 +- collects/mred/private/wx/gtk/choice.rkt | 10 +- .../mred/private/wx/gtk/client-window.rkt | 10 +- collects/mred/private/wx/gtk/clipboard.rkt | 13 +- collects/mred/private/wx/gtk/colordialog.rkt | 5 +- collects/mred/private/wx/gtk/combo.rkt | 12 +- collects/mred/private/wx/gtk/const.rkt | 2 +- collects/mred/private/wx/gtk/cursor.rkt | 7 +- collects/mred/private/wx/gtk/dc.rkt | 15 +- collects/mred/private/wx/gtk/dialog.rkt | 7 +- collects/mred/private/wx/gtk/filedialog.rkt | 3 +- collects/mred/private/wx/gtk/frame.rkt | 11 +- collects/mred/private/wx/gtk/gauge.rkt | 10 +- collects/mred/private/wx/gtk/gcwin.rkt | 11 +- collects/mred/private/wx/gtk/gl-context.rkt | 15 +- collects/mred/private/wx/gtk/group-panel.rkt | 10 +- collects/mred/private/wx/gtk/init.rkt | 9 +- collects/mred/private/wx/gtk/item.rkt | 7 +- collects/mred/private/wx/gtk/keycode.rkt | 2 +- collects/mred/private/wx/gtk/keymap.rkt | 3 +- collects/mred/private/wx/gtk/list-box.rkt | 7 +- collects/mred/private/wx/gtk/menu-bar.rkt | 16 +- collects/mred/private/wx/gtk/menu-item.rkt | 7 +- collects/mred/private/wx/gtk/menu.rkt | 10 +- collects/mred/private/wx/gtk/message.rkt | 18 +- collects/mred/private/wx/gtk/panel.rkt | 9 +- collects/mred/private/wx/gtk/pixbuf.rkt | 21 +- collects/mred/private/wx/gtk/platform.rkt | 8 +- collects/mred/private/wx/gtk/printer-dc.rkt | 19 +- collects/mred/private/wx/gtk/procs.rkt | 73 ++--- collects/mred/private/wx/gtk/queue.rkt | 9 +- collects/mred/private/wx/gtk/radio-box.rkt | 10 +- collects/mred/private/wx/gtk/slider.rkt | 10 +- collects/mred/private/wx/gtk/stddialog.rkt | 5 +- collects/mred/private/wx/gtk/style.rkt | 5 +- collects/mred/private/wx/gtk/tab-panel.rkt | 10 +- collects/mred/private/wx/gtk/types.rkt | 58 ++-- collects/mred/private/wx/gtk/unique.rkt | 5 +- collects/mred/private/wx/gtk/utils.rkt | 61 ++-- collects/mred/private/wx/gtk/widget.rkt | 19 +- collects/mred/private/wx/gtk/window.rkt | 55 ++-- collects/mred/private/wx/gtk/x11.rkt | 13 +- collects/mred/private/wx/platform.rkt | 9 +- collects/mred/private/wx/win32/button.rkt | 5 +- collects/mred/private/wx/win32/canvas.rkt | 3 +- collects/mred/private/wx/win32/check-box.rkt | 3 +- collects/mred/private/wx/win32/choice.rkt | 3 +- collects/mred/private/wx/win32/clipboard.rkt | 7 +- .../mred/private/wx/win32/colordialog.rkt | 5 +- collects/mred/private/wx/win32/const.rkt | 2 +- collects/mred/private/wx/win32/cursor.rkt | 7 +- collects/mred/private/wx/win32/dc.rkt | 19 +- collects/mred/private/wx/win32/filedialog.rkt | 3 +- collects/mred/private/wx/win32/font.rkt | 9 +- collects/mred/private/wx/win32/frame.rkt | 7 +- collects/mred/private/wx/win32/gauge.rkt | 3 +- collects/mred/private/wx/win32/gcwin.rkt | 11 +- collects/mred/private/wx/win32/gl-context.rkt | 7 +- .../mred/private/wx/win32/group-panel.rkt | 3 +- collects/mred/private/wx/win32/hbitmap.rkt | 11 +- collects/mred/private/wx/win32/item.rkt | 5 +- collects/mred/private/wx/win32/key.rkt | 5 +- collects/mred/private/wx/win32/list-box.rkt | 3 +- collects/mred/private/wx/win32/menu-bar.rkt | 3 +- collects/mred/private/wx/win32/menu-item.rkt | 7 +- collects/mred/private/wx/win32/menu.rkt | 7 +- collects/mred/private/wx/win32/message.rkt | 3 +- collects/mred/private/wx/win32/panel.rkt | 5 +- collects/mred/private/wx/win32/platform.rkt | 7 +- collects/mred/private/wx/win32/printer-dc.rkt | 17 +- collects/mred/private/wx/win32/procs.rkt | 72 ++--- collects/mred/private/wx/win32/queue.rkt | 2 +- collects/mred/private/wx/win32/radio-box.rkt | 5 +- collects/mred/private/wx/win32/slider.rkt | 3 +- collects/mred/private/wx/win32/sound.rkt | 3 +- collects/mred/private/wx/win32/tab-panel.rkt | 3 +- collects/mred/private/wx/win32/theme.rkt | 21 +- collects/mred/private/wx/win32/types.rkt | 81 ++--- collects/mred/private/wx/win32/utils.rkt | 73 ++--- collects/mred/private/wx/win32/window.rkt | 15 +- collects/mred/private/wx/win32/wndclass.rkt | 23 +- collects/scribblings/gui/miscwin-funcs.scrbl | 147 --------- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 3 + 146 files changed, 937 insertions(+), 1362 deletions(-) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 75b8aae3..505fccaa 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -530,18 +530,7 @@ the state transitions / contracts are: (cond [(string? default) string?] [(number? default) number?] - [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])) - (preferences:add-callback - name - (λ (p new-value) - (write-resource - font-section - font-entry - (if (and (string? new-value) - (string=? font-default-string new-value)) - "" - new-value) - font-file))))))]) + [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))]) (for-each (set-default build-font-entry font-default-string string?) font-families) @@ -579,14 +568,7 @@ the state transitions / contracts are: [message (make-object message% (let ([b (box "")]) - (if (and (get-resource - font-section - (build-font-entry name) - b) - (not (string=? (unbox b) - ""))) - (unbox b) - font-default-string)) + font-default-string) horiz)] [button (make-object button% @@ -643,11 +625,7 @@ the state transitions / contracts are: [size-panel (make-object horizontal-panel% main '(border))] [initial-font-size (let ([b (box 0)]) - (if (get-resource font-section - font-size-entry - b) - (unbox b) - font-default-size))] + font-default-size)] [size-slider (make-object slider% (string-constant font-size-slider-label) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 53b52e26..47e3727f 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -93,7 +93,6 @@ get-panel-background get-ps-setup-from-user get-highlight-background-color get-highlight-text-color -get-resource get-text-from-user get-the-editor-data-class-list get-the-snip-class-list @@ -164,7 +163,6 @@ region% register-collecting-blit scroll-event% selectable-menu-item<%> -send-event send-message-to-window separator-menu-item% sleep/yield @@ -207,5 +205,4 @@ window<%> write-editor-global-footer write-editor-global-header write-editor-version -write-resource yield diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 59f6dcbf..f9aa0393 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -130,7 +130,6 @@ font-name-directory<%> get-highlight-background-color get-highlight-text-color - get-resource get-the-editor-data-class-list get-the-snip-class-list image-snip% @@ -175,12 +174,10 @@ write-editor-global-footer write-editor-global-header write-editor-version - write-resource queue-callback yield eventspace-shutdown? get-panel-background - send-event gl-context<%> gl-config% diff --git a/collects/mred/private/syntax.rkt b/collects/mred/private/syntax.rkt index b4cc868a..431e1a26 100644 --- a/collects/mred/private/syntax.rkt +++ b/collects/mred/private/syntax.rkt @@ -1,299 +1,3 @@ #lang scheme/base -(require scheme/class - scheme/stxparam - (for-syntax scheme/base)) - -(provide defclass defclass* - def/public def/public-final def/override def/override-final define/top case-args - def/public-unimplemented define-unimplemented - maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts - make-literal symbol-in integer-in real-in make-procedure - method-name init-name - let-boxes - properties field-properties init-properties - ->long - assert) - -(define-syntax-parameter class-name #f) - -(define-syntax-rule (defclass name super . body) - (defclass* name super () . body)) -(define-syntax-rule (defclass* name super intfs . body) - (define name - (syntax-parameterize ([class-name 'name]) - (class* super intfs . body)))) - -(define-syntax (def/public stx) - #`(def/thing define/public #,stx)) -(define-syntax (def/public-final stx) - #`(def/thing define/public-final #,stx)) -(define-syntax (def/override stx) - #`(def/thing define/override #,stx)) -(define-syntax (def/override-final stx) - #`(def/thing define/override-final #,stx)) -(define-syntax (define/top stx) - #`(def/thing define #,stx)) - -(define (method-name class method) - (string->symbol (format "~a in ~a" method class))) -(define (init-name class) - (string->symbol (format "initialization for ~a" class))) - -(define-syntax just-id - (syntax-rules () - [(_ [id default]) id] - [(_ id) id])) - -(define-struct named-pred (pred make-name) - #:property prop:procedure (struct-field-index pred)) - -(define (apply-pred pred val) - (cond - [(procedure? pred) (pred val)] - [(class? pred) (val . is-a? . pred)] - [(interface? pred) (val . is-a? . pred)] - [else (error 'check-arg "unknown predicate type: ~e" pred)])) - -(define (make-or-false pred) - (make-named-pred (lambda (v) - (or (not v) (apply-pred pred v))) - (lambda () - (string-append (predicate-name pred) - " or #f")))) - -(define (make-box pred) - (make-named-pred (lambda (v) - (and (box? v) (apply-pred pred (unbox v)))) - (lambda () - (string-append "boxed " (predicate-name pred))))) - -(define (make-list pred) - (make-named-pred (lambda (v) - (and (list? v) (andmap (lambda (v) (apply-pred pred v)) v))) - (lambda () - (string-append "list of " (predicate-name pred))))) - -(define (make-alts a b) - (make-named-pred (lambda (v) - (or (apply-pred a v) (apply-pred b v))) - (lambda () - (string-append (predicate-name a) - " or " - (predicate-name b))))) - -(define (make-literal lit) - (make-named-pred (lambda (v) (equal? v lit)) - (lambda () (if (symbol? lit) - (format "'~s" lit) - (format "~s" lit))))) - -(define (make-symbol syms) - (make-named-pred (lambda (v) (memq v syms)) - (lambda () - (let loop ([syms syms]) - (cond - [(null? (cdr syms)) - (format "'~s" (car syms))] - [(null? (cddr syms)) - (format "'~s, or '~s" (car syms) (cadr syms))] - [else - (format "'~s, ~a" (car syms) (loop (cdr syms)))]))))) -(define-syntax-rule (symbol-in sym ...) - (make-symbol '(sym ...))) - -(define (integer-in lo hi) - (make-named-pred (lambda (v) (and (exact-integer? v) - (<= lo v hi))) - (lambda () - (format "exact integer in [~a, ~a]" lo hi)))) -(define (real-in lo hi) - (make-named-pred (lambda (v) (and (real? v) - (<= lo v hi))) - (lambda () - (format "real in [~a, ~a]" lo hi)))) - -(define (make-procedure arity) - (make-named-pred (lambda (p) - (and (procedure? p) - (procedure-arity-includes? p arity))) - (lambda () - (format "procedure (arity ~a)" arity)))) - -(define (check-arg val pred pos) - (if (apply-pred pred val) - #f - (cons (predicate-name pred) - pos))) - -(define (predicate-name pred) - (cond - [(named-pred? pred) ((named-pred-make-name pred))] - [(procedure? pred) (let ([s (symbol->string (object-name pred))]) - (substring s 0 (sub1 (string-length s))))] - [(or (class? pred) (interface? pred)) - (format "~a instance" (object-name pred))] - [else "???"])) - -(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v))) - (lambda () "box or #f"))) -(define (any? v) #t) -(define (bool? v) #t) -(define (nonnegative-real? v) (and (real? v) (v . >= . 0))) - -(define (method-of cls nam) - (if cls - (string->symbol (format "~a method of ~a" nam cls)) - nam)) - -(define-syntax (def/thing stx) - (syntax-case stx () - [(_ define/orig (_ (id [arg-type arg] ...))) - (raise-syntax-error #f "missing body" stx)] - [(_ define/orig (_ (id [arg-type arg] ...) . body)) - (with-syntax ([(_ _ orig-stx) stx] - [(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))]) - i)] - [cname (syntax-parameter-value #'class-name)]) - (syntax/loc #'orig-stx - (define/orig (id arg ...) - (let ([bad (or (check-arg (just-id arg) arg-type pos) - ...)]) - (when bad - (raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...))) - (let () - . body))))])) - -(define-for-syntax lifted (make-hash)) -(define-syntax (lift-predicate stx) - (syntax-case stx () - [(_ id) (identifier? #'id) #'id] - [(_ expr) - (let ([d (syntax->datum #'expr)]) - (or (hash-ref lifted d #f) - (let ([id (syntax-local-lift-expression #'expr)]) - (hash-set! lifted d id) - id)))])) - -(define-syntax (case-args stx) - (syntax-case stx () - [(_ expr [([arg-type arg] ...) rhs ...] ... who) - (with-syntax ([((min-args-len . max-args-len) ...) - (map (lambda (args) - (let ([args (syntax->list args)]) - (cons (let loop ([args args]) - (if (or (null? args) - (not (identifier? (car args)))) - 0 - (add1 (loop (cdr args))))) - (length args)))) - (syntax->list #'((arg ...) ...)))]) - #'(let* ([args expr] - [len (length args)]) - (find-match - (lambda (next) - (if (and (len . >= . min-args-len) - (len . <= . max-args-len)) - (apply - (lambda (arg ...) - (if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...) - (lambda () rhs ...) - next)) - args) - next)) - ... - (lambda (next) - (bad-args who args)))))])) - -(define (bad-args who args) - (error who "bad argument combination:~a" - (apply string-append (map (lambda (x) (format " ~e" x)) - args)))) - -(define-syntax find-match - (syntax-rules () - [(_ proc) - ((proc #f))] - [(_ proc1 proc ...) - ((proc1 (lambda () (find-match proc ...))))])) - -(define-syntax-rule (let-boxes ([id init] ...) - call - body ...) - (let ([id (box init)] ...) - call - (let ([id (unbox id)] ...) - body ...))) - -(define-syntax (do-properties stx) - (syntax-case stx () - [(_ define-base check-immutable [[type id] expr] ...) - (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([(getter ...) - (map (lambda (id) - (datum->syntax id - (string->symbol - (format "get-~a" (syntax-e id))) - id)) - ids)] - [(setter ...) - (map (lambda (id) - (datum->syntax id - (string->symbol - (format "set-~a" (syntax-e id))) - id)) - ids)]) - #'(begin - (define-base id expr) ... - (define/public (getter) id) ... - (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) - -(define-syntax coerce - (syntax-rules (bool?) - [(_ bool? v) (and v #t)] - [(_ _ v) v])) - -(define-syntax properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define check-immutable . props)] - [(_ . props) - (do-properties define void . props)])) -(define-syntax field-properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define-field check-immutable . props)] - [(_ . props) - (do-properties define-field void . props)])) -(define-syntax-rule (define-field id val) (field [id val])) -(define-syntax init-properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define-init check-immutable . props)] - [(_ . props) - (do-properties define-init void . props)])) -(define-syntax-rule (define-init id val) (begin - (init [(internal id) val]) - (define id internal))) - -(define (->long i) - (cond - [(eqv? -inf.0 i) (- (expt 2 64))] - [(eqv? +inf.0 i) (expt 2 64)] - [(eqv? +nan.0 i) 0] - [else (inexact->exact (floor i))])) - - -(define-syntax-rule (assert e) (void)) -; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e))) - -(define (unimplemented c m args) (error (if c (method-name c m) m) "unimplemented; args were ~e" - args)) - -(define-syntax (def/public-unimplemented stx) - (syntax-case stx () - [(_ id) - (with-syntax ([cname (syntax-parameter-value #'class-name)]) - #'(define/public (id . args) (unimplemented 'cname 'id args)))])) - -(define-syntax-rule (define-unimplemented id) - (define (id . args) (unimplemented #f 'id args))) +(require racket/draw/private/syntax) +(provide (all-from-out racket/draw/private/syntax)) diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt index df44db48..b989a697 100644 --- a/collects/mred/private/wx/cocoa/README.txt +++ b/collects/mred/private/wx/cocoa/README.txt @@ -12,4 +12,5 @@ Allocation rules: * Other autoreleased objects may end up in the root pool installed by "pool.rkt". The root pool is periodically destroyed and replaced; call `queue-autorelease-flush' if you need to encurage replacement - of the pool. + of the pool. If you need to use an object htat might be autoflushed, + be sure that you're in atomic mode. diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 97574919..b58f18e3 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class "../../syntax.rkt" "item.rkt" "utils.rkt" @@ -10,12 +10,11 @@ "window.rkt" "../common/event.rkt" "image.rkt") -(unsafe!) -(objc-unsafe!) -(provide button% - core-button% - MyButton) +(provide + (protect-out button% + core-button% + MyButton)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 638e1c56..ee897ce3 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -3,14 +3,15 @@ ffi/unsafe racket/class racket/draw - racket/draw/gl-context - racket/draw/color + racket/draw/private/gl-context + racket/draw/private/color "pool.rkt" "utils.rkt" "const.rkt" "types.rkt" "window.rkt" "dc.rkt" + "bitmap.rkt" "cg.rkt" "queue.rkt" "item.rkt" @@ -24,7 +25,8 @@ "../../lock.rkt" "../common/freeze.rkt") -(provide canvas%) +(provide + (protect-out canvas%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/cg.rkt b/collects/mred/private/wx/cocoa/cg.rkt index 479a9dcd..b158602a 100644 --- a/collects/mred/private/wx/cocoa/cg.rkt +++ b/collects/mred/private/wx/cocoa/cg.rkt @@ -4,7 +4,7 @@ "types.rkt" "utils.rkt") -(provide (all-defined-out)) +(provide (protect-out (all-defined-out))) (define _CGContextRef (_cpointer 'CGContextRef)) (define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) diff --git a/collects/mred/private/wx/cocoa/check-box.rkt b/collects/mred/private/wx/cocoa/check-box.rkt index 6241bb17..cd2ed74a 100644 --- a/collects/mred/private/wx/cocoa/check-box.rkt +++ b/collects/mred/private/wx/cocoa/check-box.rkt @@ -1,15 +1,14 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class "../../syntax.rkt" "button.rkt" "types.rkt" "const.rkt") -(unsafe!) -(objc-unsafe!) -(provide check-box%) +(provide + (protect-out check-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 1974622d..844748e4 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "item.rkt" "types.rkt" @@ -9,10 +9,9 @@ "utils.rkt" "window.rkt" "../common/event.rkt") -(unsafe!) -(objc-unsafe!) -(provide choice%) +(provide + (protect-out choice%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index d72d854a..34eb2370 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -1,16 +1,17 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class ffi/unsafe ffi/unsafe/objc "utils.rkt" "types.rkt" "image.rkt" - "../common/bstr.rkt" + racket/draw/unsafe/bstr "../../syntax.rkt" "../../lock.rkt") -(provide clipboard-driver% - has-x-selection?) +(provide + (protect-out clipboard-driver% + has-x-selection?)) (import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext) (import-protocol NSPasteboardOwner) diff --git a/collects/mred/private/wx/cocoa/colordialog.rkt b/collects/mred/private/wx/cocoa/colordialog.rkt index 1f3a8e6b..2dc750c3 100644 --- a/collects/mred/private/wx/cocoa/colordialog.rkt +++ b/collects/mred/private/wx/cocoa/colordialog.rkt @@ -2,12 +2,13 @@ (require ffi/unsafe ffi/unsafe/objc racket/class - racket/draw/color + racket/draw/private/color "../../lock.rkt" "utils.rkt" "types.rkt") -(provide get-color-from-user) +(provide + (protect-out get-color-from-user)) (import-class NSColorPanel NSColor) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt index f8a39c5d..d2f99cb3 100644 --- a/collects/mred/private/wx/cocoa/const.rkt +++ b/collects/mred/private/wx/cocoa/const.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide (except-out (all-defined-out) <<)) diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt index 28fc4e5d..0ca120c1 100644 --- a/collects/mred/private/wx/cocoa/cursor.rkt +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -9,9 +9,10 @@ "../common/cursor-draw.rkt" "../common/local.rkt") -(provide cursor-driver% - arrow-cursor-handle - get-wait-cursor-handle) +(provide + (protect-out cursor-driver% + arrow-cursor-handle + get-wait-cursor-handle)) (import-class NSCursor) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index cd44ad58..ed311688 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -2,10 +2,10 @@ (require racket/class ffi/unsafe ffi/unsafe/objc - racket/draw/cairo - racket/draw/bitmap - racket/draw/local - racket/draw/gl-context + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/local + racket/draw/private/gl-context "types.rkt" "utils.rkt" "bitmap.rkt" @@ -15,9 +15,9 @@ "../common/backing-dc.rkt" "cg.rkt") -(provide dc% - quartz-bitmap% - do-backing-flush) +(provide + (protect-out dc% + do-backing-flush)) (import-class NSOpenGLContext) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 85b8e361..bfb8517e 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -1,12 +1,13 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class "../../syntax.rkt" "../common/queue.rkt" "../common/dialog.rkt" "../../lock.rkt" "frame.rkt") -(provide dialog%) +(provide + (protect-out dialog%)) (define dialog% (class (dialog-mixin frame%) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index c2bfc8ae..00e124e4 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -9,7 +9,8 @@ "queue.rkt" "frame.rkt") -(provide file-selector) +(provide + (protect-out file-selector)) (import-class NSOpenPanel NSSavePanel NSURL NSArray) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index 4d841bbc..b1570bea 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -4,7 +4,8 @@ "utils.rkt" "types.rkt") -(provide file-creator-and-type) +(provide + (protect-out file-creator-and-type)) (define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices"))) diff --git a/collects/mred/private/wx/cocoa/font.rkt b/collects/mred/private/wx/cocoa/font.rkt index 7b438b0a..014e0942 100644 --- a/collects/mred/private/wx/cocoa/font.rkt +++ b/collects/mred/private/wx/cocoa/font.rkt @@ -8,7 +8,8 @@ "utils.rkt" "types.rkt") -(provide font->NSFont) +(provide + (protect-out font->NSFont)) (import-class NSFont NSFontManager) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 5536d187..0edb644f 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe/objc ffi/unsafe scheme/class @@ -15,9 +15,10 @@ "../common/freeze.rkt" "../../lock.rkt") -(provide frame% - location->window - get-front) +(provide + (protect-out frame% + location->window + get-front)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index 1dfa3fce..d9d37610 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -1,18 +1,17 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe racket/math - ffi/objc + ffi/unsafe/objc "../../syntax.rkt" "item.rkt" "types.rkt" "const.rkt" "utils.rkt" "window.rkt") -(unsafe!) -(objc-unsafe!) -(provide gauge%) +(provide + (protect-out gauge%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/gc.rkt b/collects/mred/private/wx/cocoa/gc.rkt index b582a48a..8e384f37 100644 --- a/collects/mred/private/wx/cocoa/gc.rkt +++ b/collects/mred/private/wx/cocoa/gc.rkt @@ -4,9 +4,10 @@ "utils.rkt" "types.rkt") -(provide scheme_add_gc_callback - scheme_remove_gc_callback - make-gc-action-desc) +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + make-gc-action-desc)) (define objc-lib (ffi-lib "libobjc")) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index 8c70afe1..17561714 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -1,16 +1,15 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "types.rkt" "utils.rkt" "window.rkt" "panel.rkt") -(unsafe!) -(objc-unsafe!) -(provide group-panel%) +(provide + (protect-out group-panel%)) (import-class NSBox) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index e8ebe30f..ac05763a 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -2,9 +2,9 @@ (require ffi/unsafe ffi/unsafe/objc racket/class - racket/draw/cairo - racket/draw/local - "../common/bstr.rkt" + racket/draw/unsafe/cairo + racket/draw/private/local + racket/draw/unsafe/bstr "utils.rkt" "types.rkt" "const.rkt" @@ -13,8 +13,9 @@ "../../lock.rkt" (only-in '#%foreign ffi-callback)) -(provide bitmap->image - image->bitmap) +(provide + (protect-out bitmap->image + image->bitmap)) (import-class NSImage NSGraphicsContext) diff --git a/collects/mred/private/wx/cocoa/init.rkt b/collects/mred/private/wx/cocoa/init.rkt index 2c3b5fba..4764cc1f 100644 --- a/collects/mred/private/wx/cocoa/init.rkt +++ b/collects/mred/private/wx/cocoa/init.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require "pool.rkt" "queue.rkt") diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 6f3a0443..674da458 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -1,17 +1,16 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "window.rkt" "const.rkt" "types.rkt" "font.rkt") -(unsafe!) -(objc-unsafe!) -(provide item% - install-control-font) +(provide + (protect-out item% + install-control-font)) (import-class NSFont) (define sys-font (tell NSFont diff --git a/collects/mred/private/wx/cocoa/keycode.rkt b/collects/mred/private/wx/cocoa/keycode.rkt index 572d1f2c..7eb4d26f 100644 --- a/collects/mred/private/wx/cocoa/keycode.rkt +++ b/collects/mred/private/wx/cocoa/keycode.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide map-key-code) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 40f635e5..72419a0e 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class (only-in scheme/list take drop) "../../syntax.rkt" "../../lock.rkt" @@ -12,10 +12,9 @@ "window.rkt" "font.rkt" "../common/event.rkt") -(unsafe!) -(objc-unsafe!) -(provide list-box%) +(provide + (protect-out list-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index e72947f9..b8c70ae5 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require racket/class ffi/unsafe ffi/unsafe/objc @@ -10,8 +10,9 @@ "const.rkt" "queue.rkt") -(provide menu-bar% - get-menu-bar-height) +(provide + (protect-out menu-bar% + get-menu-bar-height)) (import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 672a2b7c..6f26da24 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -7,8 +7,9 @@ "types.rkt" "const.rkt") -(provide menu-item% - set-menu-item-shortcut) +(provide + (protect-out menu-item% + set-menu-item-shortcut)) (import-class NSMenuItem) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 7f9637eb..8d59c1f3 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -10,7 +10,8 @@ "window.rkt" "menu-item.rkt") -(provide menu%) +(provide + (protect-out menu%)) (import-class NSMenu NSMenuItem) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 458b3fc3..1a3896ef 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -1,18 +1,17 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc - racket/draw/bitmap +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + racket/draw/private/bitmap "../../syntax.rkt" "window.rkt" "item.rkt" "utils.rkt" "types.rkt" "image.rkt") -(unsafe!) -(objc-unsafe!) -(provide message%) +(provide + (protect-out message%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index b7903746..48a5c03f 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -1,16 +1,15 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "types.rkt" "utils.rkt" "window.rkt") -(unsafe!) -(objc-unsafe!) -(provide panel% - panel-mixin) +(provide + (protect-out panel% + panel-mixin)) (import-class NSView) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 98b0bfa7..f5e80dad 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -23,7 +23,7 @@ "tab-panel.rkt" "window.rkt" "procs.rkt") -(provide platform-values) +(provide (protect-out platform-values)) (define (platform-values) (values @@ -60,8 +60,6 @@ bell display-size display-origin - get-resource - write-resource flush-display fill-private-color cancel-quit @@ -71,7 +69,6 @@ get-double-click-time run-printout file-creator-and-type - send-event location->window shortcut-visible-in-label? unregister-collecting-blit diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt index 5a101fc4..070719d2 100644 --- a/collects/mred/private/wx/cocoa/pool.rkt +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -6,8 +6,9 @@ "const.rkt" "types.rkt") -(provide queue-autorelease-flush - autorelease-flush) +(provide + (protect-out queue-autorelease-flush + autorelease-flush)) (import-class NSAutoreleasePool) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index b48d2f04..c1224ed1 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -1,23 +1,25 @@ #lang racket/base (require racket/class racket/math - racket/draw/local - racket/draw/dc - racket/draw/cairo - racket/draw/bitmap - racket/draw/bitmap-dc - racket/draw/record-dc - racket/draw/ps-setup + racket/draw/private/local + racket/draw/private/dc + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/bitmap-dc + racket/draw/private/record-dc + racket/draw/private/ps-setup ffi/unsafe ffi/unsafe/objc "../../lock.rkt" "dc.rkt" + "bitmap.rkt" "cg.rkt" "utils.rkt" "types.rkt") -(provide printer-dc% - show-print-setup) +(provide + (protect-out printer-dc% + show-print-setup)) (import-class NSPrintOperation NSView NSGraphicsContext NSPrintInfo NSDictionary NSPageLayout diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 7b77f911..ed872b4a 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -12,6 +12,7 @@ "filedialog.rkt" "colordialog.rkt" "dc.rkt" + "bitmap.rkt" "printer-dc.rkt" "../common/printer.rkt" "menu-bar.rkt" @@ -26,54 +27,45 @@ (provide - application-file-handler - application-quit-handler - application-about-handler - application-pref-handler - color-from-user-platform-mode - get-color-from-user - font-from-user-platform-mode - get-font-from-user - get-panel-background - play-sound - find-graphical-system-path - register-collecting-blit - unregister-collecting-blit - shortcut-visible-in-label? - send-event - file-creator-and-type - run-printout - get-double-click-time - get-control-font-face - get-control-font-size - get-control-font-size-in-pixels? - cancel-quit - fill-private-color - flush-display - write-resource - get-resource - display-origin - display-size - bell - hide-cursor - get-display-depth - is-color-display? - file-selector - id-to-menu-item - show-print-setup - can-show-print-setup? - get-highlight-background-color - get-highlight-text-color + (protect-out + color-from-user-platform-mode + font-from-user-platform-mode + get-font-from-user + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + display-origin + display-size + bell + hide-cursor + get-display-depth + is-color-display? + id-to-menu-item + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) make-screen-bitmap make-gl-bitmap - check-for-break) + show-print-setup + get-color-from-user + get-panel-background + fill-private-color + flush-display + play-sound + file-creator-and-type + file-selector) (import-class NSScreen NSCursor) (define-unimplemented find-graphical-system-path) -(define-unimplemented send-event) -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define (color-from-user-platform-mode) "Show Picker") diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 7d73a699..10d68f7c 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -1,8 +1,8 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe/objc ffi/unsafe - scheme/class - racket/draw/dc + racket/class + racket/draw/private/dc "pool.rkt" "utils.rkt" "const.rkt" @@ -12,21 +12,21 @@ "../../lock.rkt" "../common/freeze.rkt") -(provide app - cocoa-start-event-pump - cocoa-install-event-wakeup - queue-event - set-eventspace-hook! - set-front-hook! - set-menu-bar-hooks! - post-dummy-event +(provide + (protect-out app + cocoa-start-event-pump + cocoa-install-event-wakeup + set-eventspace-hook! + set-front-hook! + set-menu-bar-hooks! + post-dummy-event - try-to-sync-refresh + try-to-sync-refresh) - ;; from common/queue: - current-eventspace - queue-event - yield) + ;; from common/queue: + current-eventspace + queue-event + yield) (import-class NSApplication NSAutoreleasePool NSColor) (import-protocol NSApplicationDelegate) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index be329cb6..ff799116 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "item.rkt" "button.rkt" @@ -11,10 +11,9 @@ "window.rkt" "../common/event.rkt" "image.rkt") -(unsafe!) -(objc-unsafe!) -(provide radio-box%) +(provide + (protect-out radio-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 35170d85..146352ed 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class - scheme/foreign - ffi/objc +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc "../../syntax.rkt" "item.rkt" "types.rkt" @@ -12,10 +12,9 @@ "../common/queue.rkt" "../common/freeze.rkt" "../../lock.rkt") -(unsafe!) -(objc-unsafe!) -(provide slider%) +(provide + (protect-out slider%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/cocoa/sound.rkt b/collects/mred/private/wx/cocoa/sound.rkt index ac0a28ef..ec31b205 100644 --- a/collects/mred/private/wx/cocoa/sound.rkt +++ b/collects/mred/private/wx/cocoa/sound.rkt @@ -4,7 +4,8 @@ "utils.rkt" "types.rkt") -(provide play-sound) +(provide + (protect-out play-sound)) (import-class NSSound) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index d5f8a397..62a22c5e 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -13,7 +13,8 @@ "../common/procs.rkt" (for-syntax racket/base)) -(provide tab-panel%) +(provide + (protect-out tab-panel%)) (define-runtime-path psm-tab-bar-dir '(so "PSMTabBarControl.framework")) diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index accaffc8..5e577c95 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -1,20 +1,19 @@ -#lang scheme/base -(require ffi/objc - scheme/foreign +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe "../../lock.rkt" "utils.rkt") -(unsafe!) -(objc-unsafe!) -(provide _NSInteger _NSUInteger - _CGFloat - _NSPoint _NSPoint-pointer (struct-out NSPoint) - _NSSize _NSSize-pointer (struct-out NSSize) - _NSRect _NSRect-pointer (struct-out NSRect) - _NSRange _NSRange-pointer (struct-out NSRange) - NSObject - NSString _NSString - NSNotFound) +(provide + (protect-out _NSInteger _NSUInteger + _CGFloat + _NSPoint _NSPoint-pointer (struct-out NSPoint) + _NSSize _NSSize-pointer (struct-out NSSize) + _NSRect _NSRect-pointer (struct-out NSRect) + _NSRange _NSRange-pointer (struct-out NSRange) + NSObject + NSString _NSString + NSNotFound)) (define _NSInteger _long) (define _NSUInteger _ulong) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index b1553187..42c62ebf 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe/objc ffi/unsafe ffi/unsafe/alloc @@ -6,22 +6,23 @@ "../common/utils.rkt" "../../lock.rkt") -(provide cocoa-lib - cf-lib - define-cocoa - define-cf - define-appserv - define-appkit - define-mz - as-objc-allocation - as-objc-allocation-with-retain - clean-up-deleted - retain release - with-autorelease - clean-menu-label - ->wxb - ->wx - old-cocoa?) +(provide + (protect-out cocoa-lib + cf-lib + define-cocoa + define-cf + define-appserv + define-appkit + as-objc-allocation + as-objc-allocation-with-retain + clean-up-deleted + retain release + with-autorelease + clean-menu-label + ->wxb + ->wx + old-cocoa?) + define-mz) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b937b47b..b4daaa97 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -1,7 +1,7 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe/objc ffi/unsafe - scheme/class + racket/class "queue.rkt" "utils.rkt" "const.rkt" @@ -17,23 +17,24 @@ "../../syntax.rkt" "../common/freeze.rkt") -(provide window% +(provide + (protect-out window% - FocusResponder - KeyMouseResponder - KeyMouseTextResponder - CursorDisplayer + FocusResponder + KeyMouseResponder + KeyMouseTextResponder + CursorDisplayer - queue-window-event - queue-window-refresh-event - queue-window*-event - request-flush-delay - cancel-flush-delay - make-init-point - flush-display + queue-window-event + queue-window-refresh-event + queue-window*-event + request-flush-delay + cancel-flush-delay + make-init-point + flush-display - special-control-key - special-option-key) + special-control-key + special-option-key)) (define-local-member-name flip-client) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 1c4f9669..f6c9b3b5 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -1,25 +1,26 @@ #lang racket/base (require racket/class - racket/draw/dc - racket/draw/bitmap-dc - racket/draw/bitmap - racket/draw/local + racket/draw/private/dc + racket/draw/private/bitmap-dc + racket/draw/private/bitmap + racket/draw/private/local "../../lock.rkt" "queue.rkt") -(provide backing-dc% - - ;; scoped method names: - get-backing-size - queue-backing-flush - on-backing-flush - start-backing-retained - end-backing-retained - reset-backing-retained - make-backing-bitmap - request-delay - cancel-delay - end-delay) +(provide + (protect-out backing-dc% + + ;; scoped method names: + get-backing-size + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained + make-backing-bitmap + request-delay + cancel-delay + end-delay)) (define-local-member-name get-backing-size @@ -35,8 +36,7 @@ (define backing-dc% (class (dc-mixin bitmap-dc-backend%) - (inherit call-with-cr-lock - internal-get-bitmap + (inherit internal-get-bitmap internal-set-bitmap reset-cr) @@ -87,12 +87,12 @@ (release-backing-bitmap bm))))) (define/public (start-backing-retained) - (call-with-cr-lock + (as-entry (lambda () (set! retained-counter (add1 retained-counter))))) (define/public (end-backing-retained) - (call-with-cr-lock + (as-entry (lambda () (if (zero? retained-counter) (log-error "unbalanced end-on-paint") diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 2e428a41..2822e41e 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -3,9 +3,10 @@ racket/draw "backing-dc.rkt") -(provide canvas-autoscroll-mixin - canvas-mixin - fix-bitmap-size) +(provide + (protect-out canvas-autoscroll-mixin + canvas-mixin + fix-bitmap-size)) ;; Implements canvas autoscroll, applied *before* platform-specific canvas ;; methods: diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt index af22c334..383394fd 100644 --- a/collects/mred/private/wx/common/clipboard.rkt +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -5,10 +5,11 @@ "local.rkt" "queue.rkt") -(provide clipboard<%> - clipboard-client% - get-the-clipboard - get-the-x-selection) +(provide + (protect-out clipboard<%> + clipboard-client% + get-the-clipboard + get-the-x-selection)) (defclass clipboard-client% object% (define types null) diff --git a/collects/mred/private/wx/common/default-procs.rkt b/collects/mred/private/wx/common/default-procs.rkt index 5034f1be..52598374 100644 --- a/collects/mred/private/wx/common/default-procs.rkt +++ b/collects/mred/private/wx/common/default-procs.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/class - racket/draw/color) + racket/draw/private/color) (provide special-control-key special-option-key file-creator-and-type diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index 0a348b08..7898a2d3 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -2,8 +2,9 @@ (require "../../lock.rkt" "queue.rkt") -(provide do-request-flush-delay - do-cancel-flush-delay) +(provide + (protect-out do-request-flush-delay + do-cancel-flush-delay)) (define (do-request-flush-delay win disable enable) (atomically diff --git a/collects/mred/private/wx/common/dialog.rkt b/collects/mred/private/wx/common/dialog.rkt index 1548fb06..319b265f 100644 --- a/collects/mred/private/wx/common/dialog.rkt +++ b/collects/mred/private/wx/common/dialog.rkt @@ -3,7 +3,7 @@ "../../lock.rkt" "queue.rkt") -(provide dialog-mixin) +(provide (protect-out dialog-mixin)) (define dialog-level-counter 0) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index 1c757d79..e9820fe3 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class "../../syntax.rkt") (provide event% diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 28b3fecc..92c15665 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -1,9 +1,10 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe/try-atomic "queue.rkt") -(provide call-as-nonatomic-retry-point - constrained-reply) +(provide + call-as-nonatomic-retry-point + (protect-out constrained-reply)) (define (internal-error str) (log-error diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt index 9fad1616..3776fd01 100644 --- a/collects/mred/private/wx/common/handlers.rkt +++ b/collects/mred/private/wx/common/handlers.rkt @@ -1,11 +1,12 @@ #lang racket/base -(provide application-file-handler - application-quit-handler - application-about-handler - application-pref-handler - - nothing-application-pref-handler) +(provide + (protect-out application-file-handler + application-quit-handler + application-about-handler + application-pref-handler + + nothing-application-pref-handler)) (define saved-files null) (define afh (lambda (f) diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt index 0f1d6a08..82a8c6b6 100644 --- a/collects/mred/private/wx/common/local.rkt +++ b/collects/mred/private/wx/common/local.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class) +#lang racket/base +(require racket/class) -(provide (all-defined-out)) +(provide (protect-out (all-defined-out))) (define-local-member-name ;; clipboard-client%: diff --git a/collects/mred/private/wx/common/once.rkt b/collects/mred/private/wx/common/once.rkt index c0e49a64..d4167541 100644 --- a/collects/mred/private/wx/common/once.rkt +++ b/collects/mred/private/wx/common/once.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe) -(provide scheme_register_process_global) +(provide (protect-out scheme_register_process_global)) ;; This module must be instantiated only once: diff --git a/collects/mred/private/wx/common/procs.rkt b/collects/mred/private/wx/common/procs.rkt index 362911fc..6434cc48 100644 --- a/collects/mred/private/wx/common/procs.rkt +++ b/collects/mred/private/wx/common/procs.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require "../../syntax.rkt") (provide diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 7882a650..b54cbd35 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -1,6 +1,6 @@ #lang racket/base (require ffi/unsafe - racket/draw/utils + racket/draw/private/utils ffi/unsafe/atomic racket/class "rbtree.rkt" @@ -8,52 +8,53 @@ "handlers.rkt" "once.rkt") -(provide queue-evt - set-check-queue! - set-queue-wakeup! +(provide + (protect-out queue-evt + set-check-queue! + set-queue-wakeup! - add-event-boundary-callback! - add-event-boundary-sometimes-callback! - remove-event-boundary-callback! - pre-event-sync - boundary-tasks-ready-evt + add-event-boundary-callback! + add-event-boundary-sometimes-callback! + remove-event-boundary-callback! + pre-event-sync + boundary-tasks-ready-evt - eventspace? - current-eventspace - queue-event - queue-refresh-event - yield - yield-refresh - (rename-out [make-new-eventspace make-eventspace]) + eventspace? + current-eventspace + queue-event + queue-refresh-event + yield + yield-refresh + (rename-out [make-new-eventspace make-eventspace]) - event-dispatch-handler - eventspace-shutdown? - main-eventspace? - eventspace-handler-thread - eventspace-wait-cursor-count - eventspace-extra-table - eventspace-adjust-external-modal! + event-dispatch-handler + eventspace-shutdown? + main-eventspace? + eventspace-handler-thread + eventspace-wait-cursor-count + eventspace-extra-table + eventspace-adjust-external-modal! - queue-callback - middle-queue-key + queue-callback + middle-queue-key - make-timer-callback - add-timer-callback - remove-timer-callback + make-timer-callback + add-timer-callback + remove-timer-callback - register-frame-shown - get-top-level-windows - other-modal? + register-frame-shown + get-top-level-windows + other-modal? - queue-quit-event - queue-prefs-event - queue-file-event + queue-quit-event + queue-prefs-event + queue-file-event - begin-busy-cursor - end-busy-cursor - is-busy? + begin-busy-cursor + end-busy-cursor + is-busy?) - scheme_register_process_global) + scheme_register_process_global) ;; ------------------------------------------------------------ ;; Create a Scheme evt that is ready when a queue is nonempty diff --git a/collects/mred/private/wx/common/rbtree.rkt b/collects/mred/private/wx/common/rbtree.rkt index a01817e1..884cc91b 100644 --- a/collects/mred/private/wx/common/rbtree.rkt +++ b/collects/mred/private/wx/common/rbtree.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base ;;; red-black-tree.rkt -- Jens Axel S�gaard and Carl Eastlund -- 3rd nov 2003 @@ -60,8 +60,8 @@ ;; SETS IMPLEMENTED AS REB-BLACK TREES. -(require scheme/match - (for-syntax scheme/base)) +(require racket/match + (for-syntax racket/base)) (define-match-expander $ (lambda (stx) (syntax-case stx () diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt index 0a950e86..289eb651 100644 --- a/collects/mred/private/wx/common/timer.rkt +++ b/collects/mred/private/wx/common/timer.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class "../../syntax.rkt" "../../lock.rkt" "queue.rkt") diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 1d9948dc..7a27dbfe 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -3,6 +3,6 @@ ffi/unsafe/define "once.rkt") -(provide define-mz) +(provide (protect-out define-mz)) (define-ffi-definer define-mz #f) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index a064b586..4d5a6499 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "../../lock.rkt" "item.rkt" @@ -11,10 +11,10 @@ "pixbuf.rkt" "message.rkt" "../common/event.rkt") -(unsafe!) -(provide button% - button-core%) +(provide + (protect-out button% + button-core%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 977ea3a5..bbc494d0 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -3,8 +3,8 @@ racket/class racket/draw ffi/unsafe/alloc - racket/draw/color - racket/draw/local + racket/draw/private/color + racket/draw/private/local "../common/backing-dc.rkt" "../common/canvas-mixin.rkt" "../../syntax.rkt" @@ -22,7 +22,8 @@ "pixbuf.rkt" "gcwin.rkt") -(provide canvas%) +(provide + (protect-out canvas%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt index f8eede10..f9efa580 100644 --- a/collects/mred/private/wx/gtk/check-box.rkt +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -1,14 +1,14 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "button.rkt" "utils.rkt" "types.rkt" "../../lock.rkt") -(unsafe!) -(provide check-box%) +(provide + (protect-out check-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 9127a229..39802d2c 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "../../lock.rkt" "item.rkt" @@ -10,9 +10,9 @@ "combo.rkt" "../common/event.rkt" "../common/queue.rkt") -(unsafe!) -(provide choice%) +(provide + (protect-out choice%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index ed86c963..4382815f 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -1,15 +1,15 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "widget.rkt" "window.rkt" "utils.rkt" "const.rkt" "types.rkt") -(unsafe!) -(provide client-size-mixin) +(provide + (protect-out client-size-mixin)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index e74f3d23..06f01340 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -2,20 +2,21 @@ (require racket/class ffi/unsafe ffi/unsafe/alloc + racket/draw/unsafe/bstr "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" - "../common/bstr.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") -(provide clipboard-driver% - has-x-selection? - _GtkSelectionData - gtk_selection_data_get_length - gtk_selection_data_get_data) +(provide + (protect-out clipboard-driver% + has-x-selection? + _GtkSelectionData + gtk_selection_data_get_length + gtk_selection_data_get_data)) (define (has-x-selection?) #t) diff --git a/collects/mred/private/wx/gtk/colordialog.rkt b/collects/mred/private/wx/gtk/colordialog.rkt index c836da71..1c26323d 100644 --- a/collects/mred/private/wx/gtk/colordialog.rkt +++ b/collects/mred/private/wx/gtk/colordialog.rkt @@ -1,12 +1,13 @@ #lang racket/base (require ffi/unsafe racket/class - racket/draw/color + racket/draw/private/color "types.rkt" "utils.rkt" "stddialog.rkt") -(provide get-color-from-user) +(provide + (protect-out get-color-from-user)) (define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/combo.rkt b/collects/mred/private/wx/gtk/combo.rkt index d0c08c37..212aadfe 100644 --- a/collects/mred/private/wx/gtk/combo.rkt +++ b/collects/mred/private/wx/gtk/combo.rkt @@ -1,16 +1,16 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "types.rkt" "utils.rkt" "window.rkt") -(unsafe!) ;; Hacks for working with GtkComboBox[Entry] -(provide extract-combo-button - connect-combo-key-and-mouse) +(provide + (protect-out extract-combo-button + connect-combo-key-and-mouse)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/const.rkt b/collects/mred/private/wx/gtk/const.rkt index 54b8cb0e..f7650353 100644 --- a/collects/mred/private/wx/gtk/const.rkt +++ b/collects/mred/private/wx/gtk/const.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide (except-out (all-defined-out) <<)) diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index 564e6536..da92895a 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -8,9 +8,10 @@ "../common/cursor-draw.rkt" "../../syntax.rkt") -(provide cursor-driver% - get-arrow-cursor-handle - get-watch-cursor-handle) +(provide + (protect-out cursor-driver% + get-arrow-cursor-handle + get-watch-cursor-handle)) (define GDK_ARROW 2) ; ugly! (define GDK_CROSSHAIR 34) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 331f7f3a..bc770391 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -9,15 +9,16 @@ "gl-context.rkt" "../../lock.rkt" "../common/backing-dc.rkt" - racket/draw/cairo - racket/draw/dc - racket/draw/bitmap - racket/draw/local + racket/draw/unsafe/cairo + racket/draw/private/dc + racket/draw/private/bitmap + racket/draw/private/local ffi/unsafe/alloc) -(provide dc% - do-backing-flush - x11-bitmap%) +(provide + (protect-out dc% + do-backing-flush + x11-bitmap%)) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 04477ac8..209930d9 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" @@ -9,7 +9,8 @@ "utils.rkt" "frame.rkt") -(provide dialog%) +(provide + (protect-out dialog%)) (define GTK_WIN_POS_CENTER 1) (define GTK_WIN_POS_CENTER_ON_PARENT 4) diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt index 97034faa..9520771f 100644 --- a/collects/mred/private/wx/gtk/filedialog.rkt +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -12,7 +12,8 @@ "../common/handlers.rkt" "../common/queue.rkt") -(provide file-selector) +(provide + (protect-out file-selector)) (define _GtkFileChooserDialog _GtkWidget) (define _GtkFileChooser (_cpointer 'GtkFileChooser)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c76c3de6..34916efb 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe racket/class racket/promise @@ -17,10 +17,11 @@ "pixbuf.rkt" "../common/queue.rkt") -(provide frame% - display-origin - display-size - location->window) +(provide + (protect-out frame% + display-origin + display-size + location->window)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/gauge.rkt b/collects/mred/private/wx/gtk/gauge.rkt index 2bb45011..dda1a9a5 100644 --- a/collects/mred/private/wx/gtk/gauge.rkt +++ b/collects/mred/private/wx/gtk/gauge.rkt @@ -1,15 +1,15 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "item.rkt" "utils.rkt" "types.rkt" "window.rkt" "const.rkt") -(unsafe!) -(provide gauge%) +(provide + (protect-out gauge%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/gcwin.rkt b/collects/mred/private/wx/gtk/gcwin.rkt index 49701b74..d017aeba 100644 --- a/collects/mred/private/wx/gtk/gcwin.rkt +++ b/collects/mred/private/wx/gtk/gcwin.rkt @@ -4,11 +4,12 @@ "types.rkt" "window.rkt") -(provide scheme_add_gc_callback - scheme_remove_gc_callback - create-gc-window - make-gc-show-desc - make-gc-hide-desc) +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-window + make-gc-show-desc + make-gc-hide-desc)) (define-cstruct _GdkWindowAttr ([title _string] diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt index 7f0aae79..40769f44 100644 --- a/collects/mred/private/wx/gtk/gl-context.rkt +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -3,17 +3,18 @@ ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc - (prefix-in draw: racket/draw/gl-context) - racket/draw/gl-config + (prefix-in draw: racket/draw/private/gl-context) + racket/draw/private/gl-config "types.rkt" "utils.rkt") -(provide prepare-widget-gl-context - create-widget-gl-context +(provide + (protect-out prepare-widget-gl-context + create-widget-gl-context - create-and-install-gl-context - get-gdk-pixmap - install-gl-context) + create-and-install-gl-context + get-gdk-pixmap + install-gl-context)) (define gdkglext-lib (with-handlers ([exn:fail? (lambda (exn) #f)]) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt index c864a442..734feee3 100644 --- a/collects/mred/private/wx/gtk/group-panel.rkt +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "../../lock.rkt" "window.rkt" @@ -8,9 +8,9 @@ "panel.rkt" "utils.rkt" "types.rkt") -(unsafe!) -(provide group-panel%) +(provide + (protect-out group-panel%)) (define-gtk gtk_frame_new (_fun _string -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/init.rkt b/collects/mred/private/wx/gtk/init.rkt index ba601aeb..ded4146b 100644 --- a/collects/mred/private/wx/gtk/init.rkt +++ b/collects/mred/private/wx/gtk/init.rkt @@ -1,17 +1,14 @@ -#lang scheme/base -(require scheme/foreign +#lang racket/base +(require ffi/unsafe "utils.rkt" "types.rkt" "queue.rkt") -(unsafe!) (define-gtk gtk_rc_parse_string (_fun _string -> _void)) (define-gtk gtk_rc_add_default_file (_fun _path -> _void)) -(define-gtk gtk_rc_find_module_in_path (_fun _path -> _path)) -(define-gtk gtk_rc_get_module_dir (_fun -> _path)) (when (eq? 'windows (system-type)) - (let ([dir (simplify-path (build-path (collection-path "scheme") 'up 'up "lib"))]) + (let ([dir (simplify-path (build-path (collection-path "racket") 'up 'up "lib"))]) (gtk_rc_parse_string (format "module_path \"~a\"\n" dir)) (gtk_rc_add_default_file (build-path dir "gtkrc")))) diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt index e63bfada..dbfd10bd 100644 --- a/collects/mred/private/wx/gtk/item.rkt +++ b/collects/mred/private/wx/gtk/item.rkt @@ -1,14 +1,15 @@ #lang racket/base (require ffi/unsafe racket/class - racket/draw/local + racket/draw/private/local "../../syntax.rkt" "window.rkt" "utils.rkt" "types.rkt") -(provide item% - install-control-font) +(provide + (protect-out item% + install-control-font)) (define _PangoFontDescription _pointer) (define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)) diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt index 9830dfa7..b5e7eb36 100644 --- a/collects/mred/private/wx/gtk/keycode.rkt +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide map-key-code) diff --git a/collects/mred/private/wx/gtk/keymap.rkt b/collects/mred/private/wx/gtk/keymap.rkt index fc827e06..80ff0c4e 100644 --- a/collects/mred/private/wx/gtk/keymap.rkt +++ b/collects/mred/private/wx/gtk/keymap.rkt @@ -4,7 +4,8 @@ "const.rkt" "types.rkt") -(provide get-alts) +(provide + (protect-out get-alts)) (define _GdkKeymap (_cpointer 'GdkKeymap)) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 3b18357a..a37a3401 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -1,7 +1,7 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe ffi/unsafe/define - scheme/class + racket/class (only-in racket/list take drop) "../../syntax.rkt" "../../lock.rkt" @@ -12,7 +12,8 @@ "const.rkt" "../common/event.rkt") -(provide list-box%) +(provide + (protect-out list-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index ce1e887f..45ff8b43 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "../../lock.rkt" "../common/freeze.rkt" @@ -9,12 +9,12 @@ "window.rkt" "utils.rkt" "types.rkt") -(unsafe!) -(provide menu-bar% - gtk_menu_item_new_with_mnemonic - gtk_menu_shell_append - fixup-mneumonic) +(provide + (protect-out menu-bar% + gtk_menu_item_new_with_mnemonic + gtk_menu_shell_append + fixup-mneumonic)) (define-gtk gtk_menu_bar_new (_fun -> _GtkWidget)) (define-gtk gtk_menu_shell_append (_fun _GtkWidget _GtkWidget -> _void)) diff --git a/collects/mred/private/wx/gtk/menu-item.rkt b/collects/mred/private/wx/gtk/menu-item.rkt index afe240e0..a6b6c342 100644 --- a/collects/mred/private/wx/gtk/menu-item.rkt +++ b/collects/mred/private/wx/gtk/menu-item.rkt @@ -1,8 +1,9 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class "../../syntax.rkt") -(provide menu-item%) +(provide + (protect-out menu-item%)) (defclass menu-item% object% (define/public (id) this) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index a4207ffa..732821bd 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "widget.rkt" "window.rkt" "../../syntax.rkt" @@ -10,9 +10,9 @@ "utils.rkt" "menu-bar.rkt" "../common/event.rkt") -(unsafe!) -(provide menu%) +(provide + (protect-out menu%)) (define-gtk gtk_menu_new (_fun -> _GtkWidget)) (define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index d74513fd..fd47ac52 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -1,18 +1,18 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "item.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") -(unsafe!) -(provide message% - - gtk_label_new_with_mnemonic - gtk_label_set_text_with_mnemonic - mnemonic-string) +(provide + (protect-out message% + + gtk_label_new_with_mnemonic + gtk_label_set_text_with_mnemonic + mnemonic-string)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index e485751f..280ad9aa 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class ffi/unsafe "../../syntax.rkt" "../../lock.rkt" @@ -8,8 +8,9 @@ "types.rkt" "const.rkt") -(provide panel% - panel-mixin) +(provide + (protect-out panel% + panel-mixin)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_new (_fun -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index e89507a6..d5c2733c 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -1,22 +1,23 @@ -#lang racket +#lang racket/base (require racket/class ffi/unsafe ffi/unsafe/alloc racket/draw - racket/draw/local - racket/draw/cairo + racket/draw/private/local + racket/draw/unsafe/cairo "../../lock.rkt" - "../common/bstr.rkt" + racket/draw/unsafe/bstr "utils.rkt" "types.rkt" (only-in '#%foreign ffi-callback)) -(provide bitmap->pixbuf - pixbuf->bitmap - - _GdkPixbuf - gtk_image_new_from_pixbuf - release-pixbuf) +(provide + (protect-out bitmap->pixbuf + pixbuf->bitmap + + _GdkPixbuf + gtk_image_new_from_pixbuf + release-pixbuf)) (define _GdkPixbuf (_cpointer/null 'GdkPixbuf)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 9f1d9eb2..0abd4fa3 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require "init.rkt" "button.rkt" "canvas.rkt" @@ -23,7 +23,8 @@ "tab-panel.rkt" "window.rkt" "procs.rkt") -(provide platform-values) +(provide + (protect-out platform-values)) (define (platform-values) (values @@ -60,8 +61,6 @@ bell display-size display-origin - get-resource - write-resource flush-display fill-private-color cancel-quit @@ -71,7 +70,6 @@ get-double-click-time run-printout file-creator-and-type - send-event location->window shortcut-visible-in-label? unregister-collecting-blit diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt index d72a47fa..92980523 100644 --- a/collects/mred/private/wx/gtk/printer-dc.rkt +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -1,12 +1,12 @@ #lang racket/base (require racket/class - racket/draw/local - racket/draw/dc - racket/draw/cairo - racket/draw/bitmap - racket/draw/bitmap-dc - racket/draw/record-dc - racket/draw/ps-setup + racket/draw/private/local + racket/draw/private/dc + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/bitmap-dc + racket/draw/private/record-dc + racket/draw/private/ps-setup ffi/unsafe ffi/unsafe/alloc "../common/queue.rkt" @@ -14,8 +14,9 @@ "utils.rkt" "types.rkt") -(provide printer-dc% - show-print-setup) +(provide + (protect-out printer-dc% + show-print-setup)) (define GTK_UNIT_POINTS 1) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 3ab44b98..c88d3a22 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -20,52 +20,47 @@ "../common/handlers.rkt") (provide - special-control-key - special-option-key - get-color-from-user - color-from-user-platform-mode - get-font-from-user - font-from-user-platform-mode - get-panel-background - play-sound - find-graphical-system-path - register-collecting-blit - unregister-collecting-blit - shortcut-visible-in-label? - location->window - send-event - file-creator-and-type - run-printout - get-double-click-time - get-control-font-face - get-control-font-size - get-control-font-size-in-pixels? - cancel-quit - fill-private-color - flush-display - write-resource - get-resource + (protect-out + color-from-user-platform-mode + get-font-from-user + font-from-user-platform-mode + play-sound + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + bell + hide-cursor + get-display-depth + is-color-display? + id-to-menu-item + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) + file-selector + show-print-setup display-origin display-size - bell - hide-cursor - get-display-depth - is-color-display? - file-selector - id-to-menu-item - show-print-setup - can-show-print-setup? - get-highlight-background-color - get-highlight-text-color + flush-display + location->window make-screen-bitmap make-gl-bitmap - check-for-break) + file-creator-and-type + special-control-key + special-option-key + get-panel-background + fill-private-color + get-color-from-user) (define-unimplemented find-graphical-system-path) -(define-unimplemented send-event) (define-unimplemented cancel-quit) -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define-unimplemented play-sound) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index a8c41134..b0885b51 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -10,12 +10,9 @@ "w32.rkt" "unique.rkt") -(provide gtk-start-event-pump - - try-to-sync-refresh - - set-widget-hook! - +(provide (protect-out gtk-start-event-pump + try-to-sync-refresh + set-widget-hook!) ;; from common/queue: current-eventspace queue-event diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 6039e5d4..446c410a 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "item.rkt" (except-in "utils.rkt" _GSList) @@ -11,9 +11,9 @@ "message.rkt" "../common/event.rkt" "../../lock.rkt") -(unsafe!) -(provide radio-box%) +(provide + (protect-out radio-box%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index c2888a25..b120a29a 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/foreign - scheme/class +#lang racket/base +(require ffi/unsafe + racket/class "../../syntax.rkt" "item.rkt" "utils.rkt" @@ -9,9 +9,9 @@ "const.rkt" "../common/event.rkt" "../../lock.rkt") -(unsafe!) -(provide slider%) +(provide + (protect-out slider%)) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/stddialog.rkt b/collects/mred/private/wx/gtk/stddialog.rkt index 49d6449b..f2a2dc78 100644 --- a/collects/mred/private/wx/gtk/stddialog.rkt +++ b/collects/mred/private/wx/gtk/stddialog.rkt @@ -7,8 +7,9 @@ "queue.rkt" "../common/queue.rkt") -(provide show-dialog - _GtkResponse) +(provide + (protect-out show-dialog + _GtkResponse)) (define _GtkResponse (_enum diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt index 808f585a..4cc7f1e6 100644 --- a/collects/mred/private/wx/gtk/style.rkt +++ b/collects/mred/private/wx/gtk/style.rkt @@ -4,8 +4,9 @@ "utils.rkt" "init.rkt") -(provide get-selected-text-color - get-selected-background-color) +(provide + (protect-out get-selected-text-color + get-selected-background-color)) (define-cstruct _GTypeInstance ([class _pointer])) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 75ad7e1d..33dfaa0c 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/class - scheme/foreign +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" "window.rkt" "client-window.rkt" @@ -10,9 +10,9 @@ "widget.rkt" "message.rkt" "../common/event.rkt") -(unsafe!) -(provide tab-panel%) +(provide + (protect-out tab-panel%)) (define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 7d2fd03a..0274dc50 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -1,35 +1,35 @@ -#lang scheme/base -(require scheme/foreign) -(unsafe!) +#lang racket/base +(require ffi/unsafe) -(provide _GdkWindow - _GtkWidget _GtkWindow - _GdkDisplay - _GdkScreen - _gpointer - _GType +(provide + (protect-out _GdkWindow + _GtkWidget _GtkWindow + _GdkDisplay + _GdkScreen + _gpointer + _GType - _fnpointer - _gboolean - _gfloat + _fnpointer + _gboolean + _gfloat - _GdkEventButton _GdkEventButton-pointer - (struct-out GdkEventButton) - _GdkEventKey _GdkEventKey-pointer - (struct-out GdkEventKey) - _GdkEventScroll _GdkEventScroll-pointer - (struct-out GdkEventScroll) - _GdkEventMotion _GdkEventMotion-pointer - (struct-out GdkEventMotion) - _GdkEventCrossing _GdkEventCrossing-pointer - (struct-out GdkEventCrossing) - _GdkEventConfigure _GdkEventConfigure-pointer - (struct-out GdkEventConfigure) - _GdkEventExpose _GdkEventExpose-pointer - (struct-out GdkEventExpose) - (struct-out GdkRectangle) - _GdkColor _GdkColor-pointer - (struct-out GdkColor)) + _GdkEventButton _GdkEventButton-pointer + (struct-out GdkEventButton) + _GdkEventKey _GdkEventKey-pointer + (struct-out GdkEventKey) + _GdkEventScroll _GdkEventScroll-pointer + (struct-out GdkEventScroll) + _GdkEventMotion _GdkEventMotion-pointer + (struct-out GdkEventMotion) + _GdkEventCrossing _GdkEventCrossing-pointer + (struct-out GdkEventCrossing) + _GdkEventConfigure _GdkEventConfigure-pointer + (struct-out GdkEventConfigure) + _GdkEventExpose _GdkEventExpose-pointer + (struct-out GdkEventExpose) + (struct-out GdkRectangle) + _GdkColor _GdkColor-pointer + (struct-out GdkColor))) (define _GType _long) diff --git a/collects/mred/private/wx/gtk/unique.rkt b/collects/mred/private/wx/gtk/unique.rkt index ca139be8..5385a725 100644 --- a/collects/mred/private/wx/gtk/unique.rkt +++ b/collects/mred/private/wx/gtk/unique.rkt @@ -1,13 +1,14 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define - racket/draw/bstr + racket/draw/unsafe/bstr net/base64 "../common/queue.rkt" "types.rkt" "utils.rkt") -(provide do-single-instance) +(provide + (protect-out do-single-instance)) (define unique-lib (with-handlers ([exn:fail? (lambda (exn) #f)]) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index f92202c1..180533b7 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc @@ -6,46 +6,47 @@ "../common/utils.rkt" "types.rkt") -(provide define-gtk - define-gdk - define-gobj - define-gio - define-glib - define-gdk_pixbuf - define-mz +(provide + define-mz + (protect-out define-gtk + define-gdk + define-gobj + define-gio + define-glib + define-gdk_pixbuf - g_object_ref - g_object_ref_sink - g_object_unref + g_object_ref + g_object_ref_sink + g_object_unref - gobject-ref - gobject-unref - as-gobject-allocation + gobject-ref + gobject-unref + as-gobject-allocation - as-gtk-allocation - as-gtk-window-allocation + as-gtk-allocation + as-gtk-window-allocation - g_free - _gpath/free - _GSList - gfree + g_free + _gpath/free + _GSList + gfree - g_object_set_data - g_object_get_data + g_object_set_data + g_object_get_data - g_object_new + g_object_new - (rename-out [g_object_get g_object_get_window]) + (rename-out [g_object_get g_object_get_window]) - get-gtk-object-flags - set-gtk-object-flags! + get-gtk-object-flags + set-gtk-object-flags! - define-signal-handler + define-signal-handler - gdk_screen_get_default + gdk_screen_get_default - ;; for declaring derived structures: - _GtkObject) + ;; for declaring derived structures: + _GtkObject)) (define gdk-lib (case (system-type) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index 4ee5f740..ed9e5327 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -8,17 +8,18 @@ "utils.rkt" "types.rkt") -(provide widget% - gtk->wx +(provide + (protect-out widget% + gtk->wx - gtk_widget_show - gtk_widget_hide - gtk_widget_destroy + gtk_widget_show + gtk_widget_hide + gtk_widget_destroy - gtk_vbox_new - gtk_hbox_new - gtk_box_pack_start - gtk_box_pack_end) + gtk_vbox_new + gtk_hbox_new + gtk_box_pack_start + gtk_box_pack_end)) (define-gtk gtk_widget_show (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 0aa30e25..b55c04c1 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -9,7 +9,7 @@ "../common/queue.rkt" "../common/local.rkt" "../common/delay.rkt" - "../common/bstr.rkt" + racket/draw/unsafe/bstr "keycode.rkt" "keymap.rkt" "queue.rkt" @@ -19,39 +19,40 @@ "widget.rkt" "clipboard.rkt") -(provide window% - gtk->wx - queue-window-event - queue-window-refresh-event +(provide + (protect-out window% + queue-window-event + queue-window-refresh-event - gtk_widget_show - gtk_widget_hide - gtk_widget_realize - gtk_container_add - gtk_widget_add_events - gtk_widget_size_request - gtk_widget_set_size_request - gtk_widget_grab_focus - gtk_widget_set_sensitive + gtk_widget_realize + gtk_container_add + gtk_widget_add_events + gtk_widget_size_request + gtk_widget_set_size_request + gtk_widget_grab_focus + gtk_widget_set_sensitive - connect-focus - connect-key-and-mouse - do-button-event + connect-focus + connect-key-and-mouse + do-button-event - (struct-out GtkRequisition) _GtkRequisition-pointer - (struct-out GtkAllocation) _GtkAllocation-pointer + (struct-out GtkRequisition) _GtkRequisition-pointer + (struct-out GtkAllocation) _GtkAllocation-pointer - widget-window + widget-window - the-accelerator-group - gtk_window_add_accel_group - gtk_menu_set_accel_group + the-accelerator-group + gtk_window_add_accel_group + gtk_menu_set_accel_group - flush-display - gdk_display_get_default + flush-display + gdk_display_get_default - request-flush-delay - cancel-flush-delay) + request-flush-delay + cancel-flush-delay) + gtk->wx + gtk_widget_show + gtk_widget_hide) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/gtk/x11.rkt b/collects/mred/private/wx/gtk/x11.rkt index dce8ea4c..cda9c15a 100644 --- a/collects/mred/private/wx/gtk/x11.rkt +++ b/collects/mred/private/wx/gtk/x11.rkt @@ -4,12 +4,13 @@ ffi/unsafe/alloc "utils.rkt") -(provide gdk_pixmap_new - gdk_drawable_get_display - gdk_drawable_get_visual - gdk_x11_drawable_get_xid - gdk_x11_display_get_xdisplay - gdk_x11_visual_get_xvisual) +(provide + (protect-out gdk_pixmap_new + gdk_drawable_get_display + gdk_drawable_get_visual + gdk_x11_drawable_get_xid + gdk_x11_display_get_xdisplay + gdk_x11_visual_get_xvisual)) (define _GdkDrawable _pointer) (define _GdkDisplay (_cpointer 'GdkDisplay)) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 8ecb9b16..79dcef79 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -1,6 +1,8 @@ #lang racket/base -(require racket/runtime-path (for-syntax racket/base)) -(provide (all-defined-out)) +(require racket/runtime-path + (for-syntax racket/base)) +(provide + (protect-out (all-defined-out))) (define-runtime-module-path-index platform-lib (let ([gtk-lib @@ -45,8 +47,6 @@ bell display-size display-origin - get-resource - write-resource flush-display fill-private-color cancel-quit @@ -56,7 +56,6 @@ get-double-click-time run-printout file-creator-and-type - send-event location->window shortcut-visible-in-label? unregister-collecting-blit diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index f455c192..0c3a2924 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -12,8 +12,9 @@ "hbitmap.rkt" "types.rkt") -(provide base-button% - button%) +(provide + (protect-out base-button% + button%)) (define BM_SETSTYLE #x00F4) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index a681d2f9..f46c513b 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -20,7 +20,8 @@ "gcwin.rkt" "theme.rkt") -(provide canvas%) +(provide + (protect-out canvas%)) (define WS_EX_STATICEDGE #x00020000) (define WS_EX_CLIENTEDGE #x00000200) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 675e4ae0..3106b450 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -6,7 +6,8 @@ "utils.rkt" "const.rkt") -(provide check-box%) +(provide + (protect-out check-box%)) (define BM_GETCHECK #x00F0) (define BM_SETCHECK #x00F1) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index a584a698..940cca94 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -12,7 +12,8 @@ "wndclass.rkt" "types.rkt") -(provide choice%) +(provide + (protect-out choice%)) (define CBN_DROPDOWN 7) (define CBN_CLOSEUP 8) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index 9fca7274..3b999c69 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -2,7 +2,7 @@ (require racket/class ffi/unsafe ffi/unsafe/alloc - racket/draw/bstr + racket/draw/unsafe/bstr "../common/queue.rkt" "../../lock.rkt" "types.rkt" @@ -12,8 +12,9 @@ "wndclass.rkt" "hbitmap.rkt") -(provide clipboard-driver% - has-x-selection?) +(provide + (protect-out clipboard-driver% + has-x-selection?)) (define (has-x-selection?) #f) diff --git a/collects/mred/private/wx/win32/colordialog.rkt b/collects/mred/private/wx/win32/colordialog.rkt index 7147ef38..8a99959c 100644 --- a/collects/mred/private/wx/win32/colordialog.rkt +++ b/collects/mred/private/wx/win32/colordialog.rkt @@ -2,14 +2,15 @@ (require ffi/unsafe racket/class racket/string - racket/draw/color + racket/draw/private/color "utils.rkt" "types.rkt" "const.rkt" "wndclass.rkt" "../../lock.rkt") -(provide get-color-from-user) +(provide + (protect-out get-color-from-user)) (define-cstruct _CHOOSECOLOR ([lStructSize _DWORD] diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index b32a3072..ecfcc941 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide (all-defined-out)) (define WM_NULL #x0000) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index 3af7c172..b49bec95 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -8,9 +8,10 @@ "../common/cursor-draw.rkt" "../../syntax.rkt") -(provide cursor-driver% - get-arrow-cursor - get-wait-cursor) +(provide + (protect-out cursor-driver% + get-arrow-cursor + get-wait-cursor)) (define (MAKEINTRESOURCE v) v) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 51e3fc86..d3b6ead0 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -7,17 +7,18 @@ "../../lock.rkt" "../common/backing-dc.rkt" "../common/delay.rkt" - racket/draw/cairo - racket/draw/dc - racket/draw/bitmap - racket/draw/local + racket/draw/unsafe/cairo + racket/draw/private/dc + racket/draw/private/bitmap + racket/draw/private/local ffi/unsafe/alloc) -(provide dc% - win32-bitmap% - do-backing-flush - request-flush-delay - cancel-flush-delay) +(provide + (protect-out dc% + win32-bitmap% + do-backing-flush + request-flush-delay + cancel-flush-delay)) (define win32-bitmap% (class bitmap% diff --git a/collects/mred/private/wx/win32/filedialog.rkt b/collects/mred/private/wx/win32/filedialog.rkt index c49b225e..df03b2ca 100644 --- a/collects/mred/private/wx/win32/filedialog.rkt +++ b/collects/mred/private/wx/win32/filedialog.rkt @@ -8,7 +8,8 @@ "wndclass.rkt" "../../lock.rkt") -(provide file-selector) +(provide + (protect-out file-selector)) (define-cstruct _OPENFILENAME ([lStructSize _DWORD] diff --git a/collects/mred/private/wx/win32/font.rkt b/collects/mred/private/wx/win32/font.rkt index 4017c643..cf7a4616 100644 --- a/collects/mred/private/wx/win32/font.rkt +++ b/collects/mred/private/wx/win32/font.rkt @@ -1,9 +1,10 @@ -#lang racket +#lang racket/base (require racket/class - racket/draw/local - racket/draw/pango) + racket/draw/private/local + racket/draw/unsafe/pango) -(provide font->hfont) +(provide + (protect-out font->hfont)) (define display-font-map (pango_win32_font_map_for_display)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 2b8f1d7d..058d5caa 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -17,9 +17,10 @@ "hbitmap.rkt" "cursor.rkt") -(provide frame% - display-size - display-origin) +(provide + (protect-out frame% + display-size + display-origin)) (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) (define-user32 GetActiveWindow (_wfun -> _HWND)) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index a2799cd8..d87bf8ce 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -10,7 +10,8 @@ "wndclass.rkt" "types.rkt") -(provide gauge%) +(provide + (protect-out gauge%)) (define PBS_VERTICAL #x04) (define PBM_SETRANGE (+ WM_USER 1)) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt index 7f84bdcc..3bb5a83e 100644 --- a/collects/mred/private/wx/win32/gcwin.rkt +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -5,11 +5,12 @@ "const.rkt" "wndclass.rkt") -(provide scheme_add_gc_callback - scheme_remove_gc_callback - create-gc-dc - make-gc-show-desc - make-gc-hide-desc) +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-dc + make-gc-show-desc + make-gc-hide-desc)) (define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) (define-mz scheme_remove_gc_callback (_fun _racket -> _void)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt index 6aa27b53..bd94aeb8 100644 --- a/collects/mred/private/wx/win32/gl-context.rkt +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -3,12 +3,13 @@ ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc - racket/draw/gl-config - (prefix-in draw: racket/draw/gl-context) + racket/draw/private/gl-config + (prefix-in draw: racket/draw/private/gl-context) "types.rkt" "utils.rkt") -(provide create-gl-context) +(provide + (protect-out create-gl-context)) (define opengl32-lib (ffi-lib "opengl32.dll")) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index d77aabda..3dce9e40 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -11,7 +11,8 @@ "wndclass.rkt" "types.rkt") -(provide group-panel%) +(provide + (protect-out group-panel%)) (define group-panel% diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index 8f3c6456..4ca70954 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -1,15 +1,16 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe - racket/draw/cairo + racket/draw/unsafe/cairo racket/draw - racket/draw/local + racket/draw/private/local racket/class "types.rkt" "utils.rkt" "const.rkt") -(provide bitmap->hbitmap - hbitmap->bitmap) +(provide + (protect-out bitmap->hbitmap + hbitmap->bitmap)) (define (bitmap->hbitmap bm #:mask [mask-bm #f] diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index d9a18b8e..20477dd9 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -12,8 +12,9 @@ "hbitmap.rkt" "types.rkt") -(provide item-mixin - item%) +(provide + (protect-out item-mixin + item%)) (define (control-proc w msg wParam lParam) (let ([wx (hwnd->wx w)]) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 802b7880..a34a6760 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -6,8 +6,9 @@ "const.rkt" "../common/event.rkt") -(provide make-key-event - generates-key-event?) +(provide + (protect-out make-key-event + generates-key-event?)) (define-user32 GetKeyState (_wfun _int -> _SHORT)) (define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index c7ea846c..1ff72c98 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -13,7 +13,8 @@ "wndclass.rkt" "types.rkt") -(provide list-box%) +(provide + (protect-out list-box%)) (define WS_EX_CLIENTEDGE #x00000200) diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 73a07513..cdbf1c0f 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -8,7 +8,8 @@ "types.rkt" "const.rkt") -(provide menu-bar%) +(provide + (protect-out menu-bar%)) (define-user32 CreateMenu (_wfun -> _HMENU)) (define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index c974b6ae..ad2863fc 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require ffi/unsafe scheme/class "utils.rkt" @@ -7,8 +7,9 @@ "../../lock.rkt" "../../syntax.rkt") -(provide menu-item% - id-to-menu-item) +(provide + (protect-out menu-item% + id-to-menu-item)) ;; Menu itens are identified by 16-bit numbers, so we have ;; to keep a hash mapping them to menu items. diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index d11d4fac..0b93f5ce 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class ffi/unsafe (only-in racket/list drop take) "../../lock.rkt" @@ -10,7 +10,8 @@ "const.rkt" "menu-item.rkt") -(provide menu%) +(provide + (protect-out menu%)) (define-user32 CreatePopupMenu (_wfun -> _HMENU)) (define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 1fd05984..e4ee583c 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -13,7 +13,8 @@ "hbitmap.rkt" "types.rkt") -(provide message%) +(provide + (protect-out message%)) (define STM_SETIMAGE #x0172) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 1485ad6f..c87ae2ce 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -8,8 +8,9 @@ "const.rkt" "cursor.rkt") -(provide panel-mixin - panel%) +(provide + (protect-out panel-mixin + panel%)) (define (panel-mixin %) (class % diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 07c3629e..d6652c53 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require "init.rkt" "button.rkt" "canvas.rkt" @@ -24,7 +24,7 @@ "tab-panel.rkt" "window.rkt" "procs.rkt") -(provide platform-values) +(provide (protect-out platform-values)) (define (platform-values) (values @@ -61,8 +61,6 @@ bell display-size display-origin - get-resource - write-resource flush-display fill-private-color cancel-quit @@ -72,7 +70,6 @@ get-double-click-time run-printout file-creator-and-type - send-event location->window shortcut-visible-in-label? unregister-collecting-blit diff --git a/collects/mred/private/wx/win32/printer-dc.rkt b/collects/mred/private/wx/win32/printer-dc.rkt index 7118d219..598ea093 100644 --- a/collects/mred/private/wx/win32/printer-dc.rkt +++ b/collects/mred/private/wx/win32/printer-dc.rkt @@ -2,20 +2,21 @@ (require racket/class ffi/unsafe ffi/unsafe/alloc - racket/draw/dc - racket/draw/local - racket/draw/cairo - racket/draw/record-dc - racket/draw/bitmap-dc - racket/draw/ps-setup + racket/draw/private/dc + racket/draw/private/local + racket/draw/unsafe/cairo + racket/draw/private/record-dc + racket/draw/private/bitmap-dc + racket/draw/private/ps-setup "../../lock.rkt" "dc.rkt" "types.rkt" "utils.rkt" "const.rkt") -(provide printer-dc% - show-print-setup) +(provide + (protect-out printer-dc% + show-print-setup)) (define _HGLOBAL _pointer) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 32153d9a..331b9dbf 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -20,52 +20,48 @@ racket/draw) (provide - special-control-key - special-option-key - get-color-from-user - color-from-user-platform-mode - get-font-from-user - font-from-user-platform-mode - get-panel-background - play-sound - find-graphical-system-path - register-collecting-blit - unregister-collecting-blit - shortcut-visible-in-label? - location->window - send-event - file-creator-and-type - run-printout - get-double-click-time - get-control-font-face - get-control-font-size - get-control-font-size-in-pixels? - cancel-quit + (protect-out + color-from-user-platform-mode + get-font-from-user + font-from-user-platform-mode + get-panel-background + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + flush-display + bell + hide-cursor + get-display-depth + is-color-display? + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) fill-private-color - flush-display - write-resource - get-resource + play-sound + location->window + file-selector + show-print-setup + id-to-menu-item + file-creator-and-type display-origin display-size - bell - hide-cursor - get-display-depth - is-color-display? - file-selector - id-to-menu-item - show-print-setup - can-show-print-setup? - get-highlight-background-color - get-highlight-text-color make-screen-bitmap make-gl-bitmap - check-for-break) + special-control-key + special-option-key + get-color-from-user) + (define-unimplemented find-graphical-system-path) -(define-unimplemented send-event) (define-unimplemented cancel-quit) -(define-unimplemented write-resource) -(define-unimplemented get-resource) (define (color-from-user-platform-mode) 'dialog) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 7fd628d4..24504696 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -11,7 +11,7 @@ "../../lock.rkt" "../common/queue.rkt") -(provide win32-start-event-pump +(provide (protect-out win32-start-event-pump) ;; from common/queue: current-eventspace diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 6b3b66df..30453ffe 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require racket/class racket/draw ffi/unsafe @@ -13,7 +13,8 @@ "hbitmap.rkt" "types.rkt") -(provide radio-box%) +(provide + (protect-out radio-box%)) (define SEP 4) (define BM_SETCHECK #x00F1) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 2310b8c7..05aafb36 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -11,7 +11,8 @@ "wndclass.rkt" "types.rkt") -(provide slider%) +(provide + (protect-out slider%)) (define TBS_VERT #x0002) (define TBS_HORZ #x0000) diff --git a/collects/mred/private/wx/win32/sound.rkt b/collects/mred/private/wx/win32/sound.rkt index 02aa963b..fb526058 100644 --- a/collects/mred/private/wx/win32/sound.rkt +++ b/collects/mred/private/wx/win32/sound.rkt @@ -5,7 +5,8 @@ "types.rkt" "const.rkt") -(provide play-sound) +(provide + (protect-out play-sound)) (define-winmm PlaySoundW (_wfun _string/utf-16 _pointer _DWORD -> _BOOL)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 03b4dea1..5ff10ba0 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -12,7 +12,8 @@ "wndclass.rkt" "types.rkt") -(provide tab-panel%) +(provide + (protect-out tab-panel%)) (define TCIF_TEXT #x0001) (define TCM_SETUNICODEFORMAT #x2005) diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt index 039f4683..6b1e21f1 100644 --- a/collects/mred/private/wx/win32/theme.rkt +++ b/collects/mred/private/wx/win32/theme.rkt @@ -5,16 +5,17 @@ "const.ss" "types.ss") -(provide get-theme-logfont - get-theme-font-face - get-theme-font-size - _LOGFONT-pointer - OpenThemeData - CloseThemeData - DrawThemeParentBackground - DrawThemeBackground - DrawThemeEdge - EnableThemeDialogTexture) +(provide + (protect-out get-theme-logfont + get-theme-font-face + get-theme-font-size + _LOGFONT-pointer + OpenThemeData + CloseThemeData + DrawThemeParentBackground + DrawThemeBackground + DrawThemeEdge + EnableThemeDialogTexture)) (define _HTHEME (_cpointer 'HTHEME)) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 360e6719..1ef78ccf 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -1,52 +1,53 @@ #lang racket/base (require ffi/unsafe) -(provide _wfun - - _WORD - _DWORD - _UDWORD - _ATOM - _WPARAM - _LPARAM - _LRESULT - _BOOL - _UINT - _UINT_PTR - _BYTE - _LONG - _ULONG - _SHORT - _HRESULT - _WCHAR - _SIZE_T +(provide + (protect-out _wfun + + _WORD + _DWORD + _UDWORD + _ATOM + _WPARAM + _LPARAM + _LRESULT + _BOOL + _UINT + _UINT_PTR + _BYTE + _LONG + _ULONG + _SHORT + _HRESULT + _WCHAR + _SIZE_T - _HINSTANCE - _HWND - _HMENU - _HICON - _HCURSOR - _HBRUSH - _HDC - _HFONT - _HBITMAP - _HANDLE + _HINSTANCE + _HWND + _HMENU + _HICON + _HCURSOR + _HBRUSH + _HDC + _HFONT + _HBITMAP + _HANDLE - _COLORREF + _COLORREF - _fnpointer + _fnpointer - _permanent-string/utf-16 - utf-16-length + _permanent-string/utf-16 + utf-16-length - (struct-out POINT) _POINT _POINT-pointer - (struct-out RECT) _RECT _RECT-pointer - (struct-out MSG) _MSG _MSG-pointer + (struct-out POINT) _POINT _POINT-pointer + (struct-out RECT) _RECT _RECT-pointer + (struct-out MSG) _MSG _MSG-pointer - HIWORD - LOWORD - MAKELONG - MAKELPARAM) + HIWORD + LOWORD + MAKELONG + MAKELPARAM)) (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 7965023d..30840da7 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -5,43 +5,44 @@ "../common/utils.rkt" "types.rkt") -(provide define-gdi32 - define-user32 - define-kernel32 - define-comctl32 - define-comdlg32 - define-shell32 - define-uxtheme - define-winmm - define-mz - failed +(provide + define-mz + (protect-out define-gdi32 + define-user32 + define-kernel32 + define-comctl32 + define-comdlg32 + define-shell32 + define-uxtheme + define-winmm + failed - GetLastError - DestroyWindow - NotifyWindowDestroy - CreateWindowExW - GetWindowLongW - SetWindowLongW - SendMessageW SendMessageW/str - GetSysColor GetRValue GetGValue GetBValue make-COLORREF - CreateBitmap - CreateCompatibleBitmap - DeleteObject - CreateCompatibleDC - DeleteDC - MoveWindow - ShowWindow - EnableWindow - SetWindowTextW - SetCursor - GetDC - ReleaseDC - InvalidateRect - GetMenuState - CheckMenuItem - ModifyMenuW - RemoveMenu - SelectObject) + GetLastError + DestroyWindow + NotifyWindowDestroy + CreateWindowExW + GetWindowLongW + SetWindowLongW + SendMessageW SendMessageW/str + GetSysColor GetRValue GetGValue GetBValue make-COLORREF + CreateBitmap + CreateCompatibleBitmap + DeleteObject + CreateCompatibleDC + DeleteDC + MoveWindow + ShowWindow + EnableWindow + SetWindowTextW + SetCursor + GetDC + ReleaseDC + InvalidateRect + GetMenuState + CheckMenuItem + ModifyMenuW + RemoveMenu + SelectObject)) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index d3fd91eb..c2b8b832 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -2,7 +2,7 @@ (require ffi/unsafe racket/class racket/draw - racket/draw/bstr + racket/draw/unsafe/bstr "../../syntax.rkt" "../common/freeze.rkt" "../common/queue.rkt" @@ -19,13 +19,14 @@ "key.rkt" "font.rkt") -(provide window% - queue-window-event - queue-window-refresh-event - location->window +(provide + (protect-out window% + queue-window-event + queue-window-refresh-event + location->window - GetWindowRect - GetClientRect) + GetWindowRect + GetClientRect)) (define (unhide-cursor) (void)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 330f8da6..4e3a62f1 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -7,17 +7,18 @@ "const.rkt" "icons.rkt") -(provide hInstance - DefWindowProcW - background-hbrush - set-hwnd-wx! - set-hwnd-ctlproc! - hwnd->wx - hwnd->ctlproc - any-hwnd->wx - unregister-hwnd - MessageBoxW - _WndProc) +(provide + (protect-out hInstance + DefWindowProcW + background-hbrush + set-hwnd-wx! + set-hwnd-ctlproc! + hwnd->wx + hwnd->ctlproc + any-hwnd->wx + unregister-hwnd + MessageBoxW + _WndProc)) ;; ---------------------------------------- ;; We use the "user data" field of an HWND to diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 7771bf77..64bbb43c 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -79,9 +79,6 @@ The result depends on @racket[what], and a @racket[#f] result is only ]} - @item{@racket['setup-file] returns the path to the file - containing resources used by @racket[get-resource]; obsolete.} - @item{@racket['x-display] returns a ``path'' whose string identifies the X display if specified by either the @Flag{display} flag or the @envvar{DISPLAY} environment variable when GRacket starts under X. For @@ -127,60 +124,6 @@ Returns the color used to draw selected text or @racket[#f] if selected text is drawn with its usual color.} -@defproc[(get-resource [section string?] - [entry string?] - [value (box/c (or/c string? exact-integer?))] - [file (or/c path? false/c) #f]) - boolean?]{ - -Gets a resource value from the resource database. The resource value - is keyed on the combination of @racket[section] and @racket[entry]. The - return value is @racket[#t] if a value is found, @racket[#f] if it is - not. The type of the value initially in the @racket[value] box - determines the way that the resource is interpreted, and @racket[value] - is filled with a new value of the same type if one is found. - -If @racket[file] is @racket[#f], platform-specific resource files - are read, as determined by @racket[find-graphical-system-path] - with @indexed-racket['setup-file]. (Under X, when @racket[file] is - @racket[#f], the user's @filepath{.Xdefaults} file is also read, or the - file specified by the @filepath{XENVIRONMENT} environment variable.) - -The format of a resource entry depends on the platform. Windows - resources use the standard @filepath{.ini} format. X and Mac OS X - resources use the standard X resource format, where each entry - consists of a @racket[section].@racket[entry] resource name, a colon, and - the resource value, terminated by a newline. Section and entry names are - case-sensitive. - -@index['("registry")]{@index['("Windows registry")]{Under}} Windows, if - @racket[section] is one of the following strings, then @racket[file] - is ignored, and @racket[entry] is used as a resource path: - -@itemize[ - - @item{@indexed-racket["HKEY_CLASSES_ROOT"]} - @item{@indexed-racket["HKEY_CURRENT_CONFIG"]} - @item{@indexed-racket["HKEY_CURRENT_USER"]} - @item{@indexed-racket["HKEY_LOCAL_MACHINE"]} - @item{@indexed-racket["HKEY_USERS"]} - -] - -In that case, the @racket[entry] argument is parsed as a resource entry -path, followed by a backslash, followed by a value name. To get the -``default'' value for an entry, use the empty name. For example, the -following expression gets a command line for starting a browser: - -@racketblock[ -(let ([b (box "")]) - (get-resource "HKEY_CLASSES_ROOT" - "htmlfile\\shell\\open\\command\\" b) - (unbox b)) -] - -See also @racket[write-resource].} - @defproc[(get-window-text-extent [string string] [font (is-a?/c font%)] [combine? any/c #f]) @@ -386,71 +329,6 @@ Unregisters all blit requests installed for @racket[canvas] with @scheme[register-collecting-blit].} -@defproc[(send-event [receiver-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [event-class-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [event-id-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [direct-arg-v any/c (void)] - [argument-list list? null]) - any/c]{ - -Sends an AppleEvent or raises @racket[exn:fail:unsupported]. - -The @racket[receiver-bytes], @racket[event-class-bytes], and -@racket[event-id-bytes] arguments specify the signature of the -receiving application, the class of the AppleEvent, and the ID of -the AppleEvent. - -The @racket[direct-arg-v] value is converted (see below) and passed as -the main argument of the event; if @racket[direct-argument-v] is -@|void-const|, no main argument is sent in the event. The -@racket[argument-list] argument is a list of two-element lists -containing a typestring and value; each typestring is used ad the -keyword name of an AppleEvent argument for the associated converted -value. - -The following types of Racket values can be converted to AppleEvent -values passed to the receiver: - -@atable[ -(tline @elem{@racket[#t] or @racket[#f]} @elem{Boolean}) -(tline @elem{small integer} @elem{Long Integer}) -(tline @elem{inexact real number} @elem{Double}) -(tline @elem{string} @elem{Characters}) -(tline @elem{list of convertible values} @elem{List of converted values}) -(tline @racket[#(file _pathname)] @elem{Alias (file exists) or FSSpec (does not exist)}) -(tline @racket[#(record (_typestring _v) ...)] @elem{Record of keyword-tagged values}) -] - -If other types of values are passed to @racket[send-event] for - conversion, the @exnraise[exn:fail:unsupported]. - -The @racket[send-event] procedure does not return until the receiver -of the AppleEvent replies. The result of @racket[send-event] is the -reverse-converted reply value (see below), or the @exnraise[exn:fail] -if there is an error. If there is no error or return value, -@racket[send-event] returns @|void-const|. - -The following types of AppleEvent values can be reverse-converted into -a Racket value returned by @racket[send-event]: - -@atable[ -(tline @elem{Boolean} @elem{@racket[#t] or @racket[#f]}) -(tline @elem{Signed Integer} @elem{integer}) -(tline @elem{Float, Double, or Extended} @elem{inexact real number}) -(tline @elem{Characters} @elem{string}) -(tline @elem{List of reverse-convertible values} @elem{list of reverse-converted values}) -(tline @elem{Alias or FSSpec} @racket[#(file _pathname)]) -(tline @elem{Record of keyword-tagged values} @racket[#(record (_typestring _v) ...)]) -] - -If the AppleEvent reply contains a value that cannot be - reverse-converted, the @exnraise[exn:fail]. - -} - @defproc[(send-message-to-window [x (integer-in -10000 10000)] [y (integer-in -10000 10000)] [message any/c]) @@ -489,31 +367,6 @@ See @racket[clipboard<%>]. } -@defproc[(write-resource [section string?] - [entry string?] - [value (or/c string? exact-integer?)] - [file (or/c path-string? false/c) #f]) - boolean?]{ - -Writes a resource value to the specified resource database. The - resource value is keyed on the combination of @racket[section] and - @racket[entry], with the same special handling of @racket[entry] for - under Windows as for @racket[get-resource]. - -If @racket[file] is @racket[#f], the platform-specific resource - database is read, as determined by - @racket[find-graphical-system-path] with - @indexed-racket['setup-file]. - -The return value is @racket[#t] if the write succeeds, @racket[#f] - otherwise. (A failure indicates that the resource file cannot be - written.) - -If @racket[value] is an integer outside a platform-specific range, - @|MismatchExn|. - -See also @racket[get-resource].} - @defproc[(label-string? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a string whose length is less than or equal to @racket[200]. } diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index 6be461a7..356bc7e7 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -91,3 +91,6 @@ Changes: OpenG drawing to a bitmap requires a bitmap created with `make-gl-bitmap'. + * The `write-resource, `get-reource', and `send-event' functions have + been removed from `racket/gui/base'. If there is any demand for the + removed functionality, it will be implemented in a new library. From da874c1c0488176ed71df9c9b995b68e1587dfac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Oct 2010 07:54:33 -0600 Subject: [PATCH 332/462] v5.4.99.1, `executable-yield-handler', and `make-bitmap' etc. original commit: 05cfffdf9e13b6868a19384e88bcb9331f9631f1 --- collects/mred/mred-sig.rkt | 5 +- collects/mred/mred.rkt | 3 + collects/mred/private/gdi.rkt | 3 +- collects/mred/private/wx/cocoa/queue.rkt | 16 +- collects/mred/private/wx/common/queue.rkt | 9 + collects/mrlib/image-core.rkt | 62 +++--- collects/mrlib/private/regmk.rkt | 13 +- collects/scribblings/gui/gui.scrbl | 7 +- doc/release-notes/racket/Draw_and_GUI_5_5.txt | 186 +++++++++++------- 9 files changed, 182 insertions(+), 122 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 47e3727f..989e0ace 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -118,11 +118,13 @@ label->plain-label labelled-menu-item<%> list-box% list-control<%> +make-bitmap make-eventspace +make-gl-bitmap make-gui-empty-namespace make-gui-namespace +make-monochrome-bitmap make-screen-bitmap -make-gl-bitmap map-command-as-meta-key menu% menu-bar% @@ -156,6 +158,7 @@ put-file queue-callback radio-box% readable-snip<%> +read-bitmap read-editor-global-footer read-editor-global-header read-editor-version diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index f9aa0393..5fdbb4e1 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -102,6 +102,9 @@ begin-busy-cursor bell bitmap% + make-bitmap + read-bitmap + make-monochrome-bitmap brush% brush-list% editor-data% diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 767e1f6f..7ef08bcc 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -8,7 +8,8 @@ "wx.ss" "te.rkt" "mrtop.ss" - "mrcanvas.ss") + "mrcanvas.ss" + "syntax.rkt") (provide register-collecting-blit unregister-collecting-blit diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 10d68f7c..3175273d 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -54,9 +54,23 @@ (tellv app finishLaunching) +;; In case we were started in an executable without a bundle, +;; explicitly register with the dock so the application can receive +;; keyboard events. +;; This technique is not sanctioned by Apple --- I found the code in SDL. +(define-cstruct _CPSProcessSerNum ([lo _uint32] [hi _uint32])) +(define-appserv CPSGetCurrentProcess (_fun _CPSProcessSerNum-pointer -> _int) + #:fail (lambda () (lambda args 1))) +(define-appserv CPSEnableForegroundOperation (_fun _CPSProcessSerNum-pointer _int _int _int _int -> _int) + #:fail (lambda () #f)) +(let ([psn (make-CPSProcessSerNum 0 0)]) + (when (zero? (CPSGetCurrentProcess psn)) + (void (CPSEnableForegroundOperation psn #x03 #x3C #x2C #x1103)))) + (define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (tellv app setDelegate: app-delegate) -(tellv app activateIgnoringOtherApps: #:type _BOOL #t) +(unless (scheme_register_process_global "Racket-GUI-no-front" #f) + (tellv app activateIgnoringOtherApps: #:type _BOOL #t)) ;; For some reason, nextEventMatchingMask:... gets stuck if the ;; display changes, and it doesn't even send the diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index b54cbd35..2d0e5776 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -498,3 +498,12 @@ (send e set-wait-cursor-mode #f)))))) (define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace)))) + +;; ---------------------------------------- + +;; Before exiting, wait until frames are closed, etc.: +(executable-yield-handler + (let ([old-eyh (executable-yield-handler)]) + (lambda (v) + (yield main-eventspace) + (old-eyh v)))) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index ee1a0578..e93bf5d8 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -117,10 +117,10 @@ has been moved out). ;; - flip ;; a bitmap is: -;; - (make-bitmap (is-a?/c bitmap%) angle positive-real -;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) +;; - (make-ibitmap (is-a?/c bitmap%) angle positive-real +;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods -(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) +(define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) #:omit-define-syntaxes #:transparent #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) @@ -404,7 +404,7 @@ has been moved out). (or (polygon? shape) (line-segment? shape) (curve-segment? shape) - (bitmap? shape) + (ibitmap? shape) (np-atomic-shape? shape))) (define (np-atomic-shape? shape) @@ -412,7 +412,7 @@ has been moved out). (text? shape) (and (flip? shape) (boolean? (flip-flipped? shape)) - (bitmap? (flip-shape shape))))) + (ibitmap? (flip-shape shape))))) ;; normalize-shape : shape -> normalized-shape ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. @@ -490,8 +490,8 @@ has been moved out). (if bottom (make-overlay bottom this-one) this-one))] - [(or (bitmap? shape) (np-atomic-shape? shape)) - (let ([shape (if (bitmap? shape) + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let ([shape (if (ibitmap? shape) (make-flip #f shape) shape)]) (let ([this-one @@ -532,12 +532,12 @@ has been moved out). [else (let ([bitmap (flip-shape shape)]) (make-flip (flip-flipped? shape) - (make-bitmap (bitmap-raw-bitmap bitmap) - (bitmap-raw-mask bitmap) - (bitmap-angle bitmap) - (* x-scale (bitmap-x-scale bitmap)) - (* y-scale (bitmap-y-scale bitmap)) - (bitmap-cache bitmap))))])])) + (make-ibitmap (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap) + (ibitmap-angle bitmap) + (* x-scale (ibitmap-x-scale bitmap)) + (* y-scale (ibitmap-y-scale bitmap)) + (ibitmap-cache bitmap))))])])) (define (scale-color color x-scale y-scale) (cond @@ -875,34 +875,34 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (get-rendered-bitmap flip-bitmap) (let ([key (get-bitmap-cache-key flip-bitmap)]) (calc-rendered-bitmap flip-bitmap key) - (car (hash-ref (bitmap-cache (flip-shape flip-bitmap)) + (car (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) key)))) (define (get-rendered-mask flip-bitmap) (let ([key (get-bitmap-cache-key flip-bitmap)]) (calc-rendered-bitmap flip-bitmap key) - (cdr (hash-ref (bitmap-cache (flip-shape flip-bitmap)) + (cdr (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) key)))) (define (get-bitmap-cache-key flip-bitmap) (let ([bm (flip-shape flip-bitmap)]) (list (flip-flipped? flip-bitmap) - (bitmap-x-scale bm) - (bitmap-y-scale bm) - (bitmap-angle bm)))) + (ibitmap-x-scale bm) + (ibitmap-y-scale bm) + (ibitmap-angle bm)))) (define (calc-rendered-bitmap flip-bitmap key) (let ([bitmap (flip-shape flip-bitmap)]) (cond - [(hash-ref (bitmap-cache bitmap) key #f) => (λ (x) x)] + [(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)] [else (let ([flipped? (flip-flipped? flip-bitmap)]) - (define-values (orig-bitmap-obj orig-mask-obj) (values (bitmap-raw-bitmap bitmap) - (bitmap-raw-mask bitmap))) + (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap))) (define-values (bitmap-obj mask-obj) (cond - [(<= (* (bitmap-x-scale bitmap) - (bitmap-y-scale bitmap)) + [(<= (* (ibitmap-x-scale bitmap) + (ibitmap-y-scale bitmap)) 1) ;; since we prefer to rotate big things, we rotate first (let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)]) @@ -912,16 +912,16 @@ the mask bitmap and the original bitmap are all together in a single bytes! (let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)]) (do-rotate bitmap bitmap-obj mask-obj flipped?))])) (define pair (cons bitmap-obj mask-obj)) - (hash-set! (bitmap-cache bitmap) key pair) + (hash-set! (ibitmap-cache bitmap) key pair) pair)]))) (define (do-rotate bitmap bitmap-obj mask-obj flip?) (cond - [(and (not flip?) (zero? (bitmap-angle bitmap))) + [(and (not flip?) (zero? (ibitmap-angle bitmap))) ;; don't rotate anything in this case. (values bitmap-obj mask-obj)] [else - (let ([θ (degrees->radians (bitmap-angle bitmap))]) + (let ([θ (degrees->radians (ibitmap-angle bitmap))]) (let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)]) (let-values ([(rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ)]) @@ -933,8 +933,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! (values bm mask)))))])) (define (do-scale bitmap orig-bm orig-mask) - (let ([x-scale (bitmap-x-scale bitmap)] - [y-scale (bitmap-y-scale bitmap)]) + (let ([x-scale (ibitmap-x-scale bitmap)] + [y-scale (ibitmap-y-scale bitmap)]) (cond [(and (= 1 x-scale) (= 1 y-scale)) ;; no need to scale in this case @@ -1081,7 +1081,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [h (send bm get-height)]) (make-image (make-translate (/ w 2) (/ h 2) - (make-bitmap bm mask-bm 0 1 1 (make-hash))) + (make-ibitmap bm mask-bm 0 1 1 (make-hash))) (make-bb w h h) #f))) @@ -1125,8 +1125,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! curve-segment-color make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen - make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale - bitmap-cache + make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-raw-mask ibitmap-angle ibitmap-x-scale ibitmap-y-scale + ibitmap-cache make-flip flip? flip-flipped? flip-shape diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index 171f0622..bf5d8bf1 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -10,14 +10,15 @@ (define-syntax (define-struct/reg-mk stx) (syntax-case stx () - [(_ id . rest) + [(_ id #:reflect-id reflect-id rest ...) (let ([build-name - (λ (fmt) - (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) + (λ (fmt id) + (datum->syntax id (string->symbol (format fmt (syntax->datum id)))))]) #`(begin - (define-struct id . rest) - (add-id-constructor-pair '#,(build-name "struct:~a") - #,(build-name "make-~a"))))])) + (define-struct id rest ... #:reflection-name 'reflect-id) + (add-id-constructor-pair '#,(build-name "struct:~a" #'reflect-id) + #,(build-name "make-~a" #'id))))] + [(_ id . rest) #'(define-struct/reg-mk id #:reflect-id id . rest)])) (define (id->constructor id) (let ([line (assoc id id-constructor-pairs)]) diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 707b1017..3fced25b 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -7,14 +7,9 @@ @declare-exporting[racket/gui/base racket/gui #:use-sources (mred)] -This reference manual describes the GUI toolbox that is part of Racket - and whose core is implemented by the GRacket executable. - @defmodule*/no-declare[(racket/gui/base)]{The @racketmodname[racket/gui/base] library provides all of the class, -interface, and procedure bindings defined in this manual. At run time, -this library needs primitive graphics support that the GRacket executable -provides; this library cannot run inside the Racket executable.} +interface, and procedure bindings defined in this manual.} @defmodulelang*/no-declare[(racket/gui)]{The @racketmodname[racket/gui] language combines all bindings of the diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index 356bc7e7..f7f4fd11 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -1,96 +1,130 @@ -Changes: +GRacket, Racket, Drawing, and GUIs +---------------------------------- - * The drawing portion of the old GUI toolbox is now available as a - separate layer: `racket/draw'. This layer can be used from plain - Racket independent of the `racket/gui' library, although - `racket/gui' re-exports `racket/draw'. +Version 5.5 includes two major changes to the Racket drawing and GUI +API: - The `racket/draw' library is built on top of the widely used Cairo - drawing library and Pango text-rendering library. + * The drawing portion of the GUI toolbox is now available as a + separate layer: `racket/draw'. This layer can be used independent + of the `racket/gui/base' library, although `racket/gui' re-exports + `racket/draw'. - * Drawing to a bitmap may not produce the same results as drawing to - a canvas. Use the `make-screen-bitmap' function (from `racket/gui') - or the `make-bitmap' method of `canvas%' to obtain a bitmap that - uses the same drawing algorithms as a canvas. + (The `racket/draw' library is built on top of the widely used Cairo + drawing library and Pango text-rendering library.) - Drawing to a canvas always draws into a bitmap that is kept - offscreen and periodically flushed onto the screen. The new - `suspend-flush' and `resume-flush' methods of `canvas%' provide - some control over the timing of the flushes, which in many cases - avoids the need for (additional) double buffering of canvas - content. + * The GRacket executable is no longer strictly necessary for running + GUI programs; the `racket/gui/base' library can be used from + Racket. - * A color bitmap can have an alpha channel, instead of just a mask - bitmap. When drawing a bitmap, alpha channels are used more - consistently and automatically than mask bitmaps. More - significantly, drawing into a bitmap with an alpha channel - preserves the drawn alphas; for example, drawing a line in the - middle of an empty bitmap produces an image with non-zero alpha - only at the drawn line. + The GRacket executable still offers some additional GUI-specific + functiontality however. Most notably, GRacket is a GUI application + under Windows (as opposed to a console application, which is + launched slightly differently by the OS), GRacket is a bundle under + Mac OS X (so the dock icon is the Racket logo, for example), and + GRacket manages single-instance mode for Windows and X. - Create a bitmap with an alpha channel by supplying #t as the new - `alpha?' argument to the `bitmap%' constructor, or by loading an - image with a type like 'unknown/alpha insteda of 'unknown or - 'unknown/mask. +The drawing and GUI libraries have also changed in further small ways. - A newly created `bitmap%' has an empty content (i.e., white with - zero alpha), insteda of unspecified content. - Images can be read into a `bitmap%' from from input ports, instead - of requiring a file path. +Bitmaps +------- - * A `dc<%>' supports additional drawing transformations: a rotation - (via `set-rotation') and a general transformation matrix (via - `set-initial-matrix'). Scaling factors can be negative, which - corresponds to flipping the direction of drawing. +Drawing to a bitmap may not produce the same results as drawing to a +canvas. Use the `make-screen-bitmap' function (from `racket/gui') or +the `make-bitmap' method of `canvas%' to obtain a bitmap that uses the +same drawing algorithms as a canvas. - A transformation matrix has the form `(vector xx xy yx yy x0 y0)', - where a point (x1, y1) is transformed to a point (x2, y2) with x2 = - xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0, which is the usual - convention. +A color bitmap can have an alpha channel, instead of just a mask +bitmap. When drawing a bitmap, alpha channels are used more +consistently and automatically than mask bitmaps. More significantly, +drawing into a bitmap with an alpha channel preserves the drawn +alphas; for example, drawing a line in the middle of an empty bitmap +produces an image with non-zero alpha only at the drawn line. - New methods `translate', `scale', `rotate', and `transform' - simplify adding a further translation, scaling, rotation, or - arbitrary matrix transformation on top of the current - transformation. The new `get-translation' and `set-translation' - methods help to capture and restore transformation settings. +Only bitmaps created with the new `make-gl-bitmap' function support +OpenGL drawing. - The old translation and scaling transformations apply after the - initial matrix. The new rotation transformation applies after the - other transformations. This layering is redundant, since all - transformations can be expressed in a single matrix, but it is - backward-compatibile. Methods like `get-translation', - `set-translation', `scale', etc. help hide the reundancy. +Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap', +`make-screen-bitmap', and `make-gl-bitmap' functions to create +bitmaps, instead of using `make-object' with `bitmap%'. The new +constructors are less overloaded and provide more modern defaults +(such as alpha channels by default). - The alpha value of a `dc<%>' (as set by `set-alpha') is used for - all drawing operations, including drawing a bitmap. +Image formats can be read into a `bitmap%' from from input ports, +instead of requiring a file path. A newly created bitmap has an empty +content (i.e., white with zero alpha), instead of unspecified content. - The `draw-bitmap' and `draw-bitmap-section' methods now smooth - bitmaps while scaling, so the `draw-bitmap-section-smooth' method - of `bitmap-dc%' simply calls `draw-bitmap-section'. - * A `region%' can be created as independent of any `dc<%>', in which - cases it uses the drawing context's current transformation at the - time that it is installed as a clipping region. +Canvases +-------- - * The old 'xor mode for pens and brushes is no longer available - (since it is not supported by Cairo). +Drawing to a canvas always draws into a bitmap that is kept offscreen +and periodically flushed onto the screen. The new `suspend-flush' and +`resume-flush' methods of `canvas%' provide some control over the +timing of the flushes, which in many cases avoids the need for +(additional) double buffering of canvas content. - * The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or - `refresh' method can be a pair, which indicates that the caret is - owned by an enclosing display and the selection spans the snip or - editor. In that case, the snip or editor should refrain from - drawing a background for the selected region, and it should draw - the foreground in the color specified by - `get-highlight-text-color', if any. +OpenGL drawing in a canvas requires supplying 'gl as a style when +creating the `canvas%' instance. OpenGL and normal dc<%> drawing no +longer mix reliably in a canvas. - * OpenGL drawing in a canvas requires supplying 'gl as a style when - creating the `canvas%' instance. OpenGL and normal dc<%> drawing no - longer mix reliably in a canvas. - OpenG drawing to a bitmap requires a bitmap created with - `make-gl-bitmap'. +Drawing-Context Transformations +------------------------------- - * The `write-resource, `get-reource', and `send-event' functions have - been removed from `racket/gui/base'. If there is any demand for the - removed functionality, it will be implemented in a new library. +A `dc<%>' instance supports rotation (via `set-rotation'), negative +scaling factors for flipping, and a general transformation matrix (via +`set-initial-matrix'). A transformation matrix has the form `(vector +xx xy yx yy x0 y0)', where a point (x1, y1) is transformed to a point +(x2, y2) with x2 = xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0, +which is the usual convention. + +New methods `translate', `scale', `rotate', and `transform' simplify +adding a further translation, scaling, rotation, or arbitrary matrix +transformation on top of the current transformation. The new +`get-translation' and `set-translation' methods help to capture and +restore transformation settings. + +The old translation and scaling transformations apply after the +initial matrix. The new rotation transformation applies after the +other transformations. This layering is redundant, since all +transformations can be expressed in a single matrix, but it is +backward-compatibile. Methods like `get-translation', +`set-translation', `scale', etc. help hide the reundancy. + + +Others Drawing-Context Changes +------------------------------ + +The alpha value of a `dc<%>' (as set by `set-alpha') is used for all +drawing operations, including drawing a bitmap. + +The `draw-bitmap' and `draw-bitmap-section' methods now smooth bitmaps +while scaling, so the `draw-bitmap-section-smooth' method of +`bitmap-dc%' simply calls `draw-bitmap-section'. + +A `region%' can be created as independent of any `dc<%>', in which +cases it uses the drawing context's current transformation at the time +that it is installed as a clipping region. + +The old 'xor mode for pens and brushes is no longer available (since +it is not supported by Cairo). + + +Editor Changes +-------------- + +The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or +`refresh' method can be a pair, which indicates that the caret is +owned by an enclosing display and the selection spans the snip or +editor. In that case, the snip or editor should refrain from drawing a +background for the selected region, and it should draw the foreground +in the color specified by `get-highlight-text-color', if any. + + +Removed Functions +----------------- + +The `write-resource, `get-reource', and `send-event' functions have +been removed from `racket/gui/base'. If there is any demand for the +removed functionality, it will be implemented in a new library. From a3b555d06341953645274f9cd8e6cc486b9576a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Oct 2010 12:28:29 -0600 Subject: [PATCH 333/462] cocoa: another screen-change workaround original commit: 4891b87ea138d1ae487bed830b455da5fc38608e --- collects/mred/private/wx/cocoa/queue.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 3175273d..227de40b 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -49,7 +49,12 @@ [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) (queue-file-event (string->path filename))] [-a _void (applicationDidChangeScreenParameters: notification) - ;; Need to reset blit windows, since OS may move them incorrectly + ;; Screen changes sometimes make the event loop get stuck; + ;; hack: schedule a wake-up call in 5 seconds + (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]) + (parameterize ([current-custodian priviledged-custodian]) + (thread (lambda () (sleep 5.0))))) + ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly (void)]) (tellv app finishLaunching) @@ -77,9 +82,12 @@ ;; `applicationDidChangeScreenParameters:' callback. Unstick ;; it by posting a dummy event, since we fortunately can receive ;; a callback via CGDisplayRegisterReconfigurationCallback(). +;; This seems to unstick things enough that `applicationDidChangeScreenParameters:' +;; is called, but sometimes the event loop gets stuck after +;; that, so there's an additional hack above. (define-appserv CGDisplayRegisterReconfigurationCallback (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) -(define (on-screen-changed) (post-dummy-event)) +(define (on-screen-changed) (printf "CG\n") (post-dummy-event)) (void (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) From aa46ad7247bb0e2c7ec5f42f60ec6ef6e67dc809 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Oct 2010 23:39:54 -0600 Subject: [PATCH 334/462] v5.0.2.2 original commit: 89e8801a268ba48f60df914aca48c62c099a9f3b --- .../racket/{Draw_and_GUI_5_5.txt => Draw_and_GUI_X_Y.txt} | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename doc/release-notes/racket/{Draw_and_GUI_5_5.txt => Draw_and_GUI_X_Y.txt} (98%) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt similarity index 98% rename from doc/release-notes/racket/Draw_and_GUI_5_5.txt rename to doc/release-notes/racket/Draw_and_GUI_X_Y.txt index f7f4fd11..b881f0f4 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt @@ -1,7 +1,7 @@ GRacket, Racket, Drawing, and GUIs ---------------------------------- -Version 5.5 includes two major changes to the Racket drawing and GUI +Version X.Y includes two major changes to the Racket drawing and GUI API: * The drawing portion of the GUI toolbox is now available as a From bcf278469c8538a55487d1ae41abb07144156d54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Oct 2010 08:42:58 -0600 Subject: [PATCH 335/462] fix bug in ffi struct alignment original commit: 58e1e377348c44372cf4da144a1e0a37482bf544 --- collects/mred/private/wx/cocoa/finfo.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index b1570bea..b4090a9f 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -136,8 +136,8 @@ (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) (let ([fs (path->fsref path)] [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + (get-info v fs path) (let ([info (FSCatalogInfo-finderInfo v)]) - (get-info v fs path) (set-FileInfo-fileCreator! info (str->int creator)) (set-FileInfo-fileType! info (str->int type))) (let ([r (FSSetCatalogInfo fs From 9806913cb29122494f85e957a01f45a160f17b3d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Oct 2010 12:27:16 -0600 Subject: [PATCH 336/462] remove debugging printf original commit: 6fa9ee22a7c8e79585eb6434b20ca6650c0552f1 --- collects/mred/private/wx/cocoa/queue.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 227de40b..aec434b5 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -87,7 +87,7 @@ ;; that, so there's an additional hack above. (define-appserv CGDisplayRegisterReconfigurationCallback (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) -(define (on-screen-changed) (printf "CG\n") (post-dummy-event)) +(define (on-screen-changed) (post-dummy-event)) (void (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) From 4109af7ecb6216b3bb5a0e299bd60de85dcc3ea9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Aug 2010 19:12:47 -0400 Subject: [PATCH 337/462] avoid functions not available in Debian Stable original commit: 6065f8cf125f2917f84651c819cf55b668f002da --- collects/mred/private/wx/gtk/colordialog.rkt | 9 +++++++-- collects/mred/private/wx/gtk/procs.rkt | 4 +++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/gtk/colordialog.rkt b/collects/mred/private/wx/gtk/colordialog.rkt index 1c26323d..c850fe4b 100644 --- a/collects/mred/private/wx/gtk/colordialog.rkt +++ b/collects/mred/private/wx/gtk/colordialog.rkt @@ -7,14 +7,19 @@ "stddialog.rkt") (provide - (protect-out get-color-from-user)) + (protect-out get-color-from-user + color-dialog-works?)) (define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget)) -(define-gtk gtk_color_selection_dialog_get_color_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_color_selection_dialog_get_color_selection (_fun _GtkWidget -> _GtkWidget) + #:fail (lambda () #f)) (define-gtk gtk_color_selection_get_current_color (_fun _GtkWidget (c : (_ptr o _GdkColor)) -> _void -> c)) (define-gtk gtk_color_selection_set_current_color (_fun _GtkWidget _GdkColor-pointer -> _void)) +(define (color-dialog-works?) + (and gtk_color_selection_dialog_get_color_selection #t)) + (define (get-color-from-user message parent color) (let ([d (as-gtk-window-allocation (gtk_color_selection_dialog_new (or message "Choose Color")))] diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index c88d3a22..86e06ef1 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -64,7 +64,9 @@ (define-unimplemented play-sound) -(define (color-from-user-platform-mode) 'dialog) +(define (color-from-user-platform-mode) + (and (color-dialog-works?) + 'dialog)) (define (font-from-user-platform-mode) #f) (define-unimplemented get-font-from-user) From 12ca7d5f05fae1dce940dcd933a1be48f330f162 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Oct 2010 16:31:26 -0600 Subject: [PATCH 338/462] no need for libgio reference original commit: 9eabda614cfb3127503d0715296f7556105143b7 --- collects/mred/private/wx/gtk/utils.rkt | 9 --------- 1 file changed, 9 deletions(-) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 180533b7..5dd05e7c 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -11,7 +11,6 @@ (protect-out define-gtk define-gdk define-gobj - define-gio define-glib define-gdk_pixbuf @@ -70,13 +69,6 @@ [(unix) (ffi-lib "libglib-2.0" '("0"))] [else gdk-lib])) -(define gio-lib - (case (system-type) - [(windows) - (ffi-lib "libgio-2.0-0")] - [(unix) - (ffi-lib "libgio-2.0" '("0"))] - [else gdk-lib])) (define gmodule-lib (case (system-type) [(windows) @@ -99,7 +91,6 @@ (define-ffi-definer define-gtk gtk-lib) (define-ffi-definer define-gobj gobj-lib) -(define-ffi-definer define-gio gio-lib) (define-ffi-definer define-glib glib-lib) (define-ffi-definer define-gmodule gmodule-lib) (define-ffi-definer define-gdk gdk-lib) From 5dff07f3ef805bbbe7abcca6257f5b158ee01cc8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 29 Oct 2010 07:02:34 -0600 Subject: [PATCH 339/462] destroy windows via finalization outside of the event loop original commit: af6cad49138a4acd5812202b1e0d26e44114b53d --- collects/mred/private/wx/cocoa/gauge.rkt | 7 +++--- collects/mred/private/wx/cocoa/utils.rkt | 12 +++------- collects/mred/private/wx/common/utils.rkt | 27 ++++++++++++++++++++++- collects/mred/private/wx/gtk/queue.rkt | 1 + collects/mred/private/wx/gtk/utils.rkt | 6 ++++- collects/mred/private/wx/win32/queue.rkt | 1 + collects/mred/private/wx/win32/utils.rkt | 8 ++++++- 7 files changed, 46 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index d9d37610..153b821b 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -31,10 +31,9 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (values ; as-objc-allocation - ;; We're leaving guages for now. There's some problem - ;; releasing gauges through a finalizer. My guess is that - ;; it has something to do with animation in a separate thread. + [cocoa (let ([cocoa (as-objc-allocation + ;; Beware that a guage may be finally deallocated in + ;; a seperate OS-level thread (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 42c62ebf..02d1a0b0 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -37,18 +37,12 @@ (define delete-me null) (define (objc-delete o) - (atomically - (set! delete-me (cons o delete-me)))) + (tellv o release)) (define (clean-up-deleted) - ;; called outside the event loop to actually delete objects - ;; that might otherwise be in use during a callback - (for ([o (in-list (begin0 - delete-me - (set! delete-me null)))]) - (tellv o release))) + (free-remembered-now objc-delete)) -(define objc-allocator (allocator objc-delete)) +(define objc-allocator (allocator remember-to-free-later)) (define-syntax-rule (as-objc-allocation expr) ((objc-allocator (lambda () expr)))) diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt index 7a27dbfe..2fcf5748 100644 --- a/collects/mred/private/wx/common/utils.rkt +++ b/collects/mred/private/wx/common/utils.rkt @@ -1,8 +1,33 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define + ffi/unsafe/atomic "once.rkt") -(provide (protect-out define-mz)) +(provide (protect-out define-mz + + remember-to-free-later + free-remembered-now)) (define-ffi-definer define-mz #f) + +;; ---------------------------------------- + +(define to-free null) + +;; Remember to free an object that might currently be in use during a +;; callback: +(define (remember-to-free-later o) + (start-atomic) + (set! to-free (cons o to-free)) + (end-atomic)) + +;; Called outside the event loop to actually free objects that might +;; otherwise be in use during a callback: +(define (free-remembered-now free) + (start-atomic) + (for ([o (in-list (begin0 + to-free + (set! to-free null)))]) + (free o)) + (end-atomic)) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index b0885b51..e42d3100 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -183,6 +183,7 @@ (define (dispatch-all-ready) (pre-event-sync #f) + (clean-up-destroyed) (when (gtk_events_pending) (gtk_main_iteration_do #f) (dispatch-all-ready))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 5dd05e7c..16d569ef 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -24,6 +24,7 @@ as-gtk-allocation as-gtk-window-allocation + clean-up-destroyed g_free _gpath/free @@ -113,7 +114,10 @@ (define gtk-destroy ((deallocator) (lambda (v) (gtk_widget_destroy v) (g_object_unref v)))) -(define gtk-allocator (allocator gtk-destroy)) + +(define gtk-allocator (allocator remember-to-free-later)) +(define (clean-up-destroyed) + (free-remembered-now gtk-destroy)) (define-syntax-rule (as-gtk-allocation expr) ((gtk-allocator (lambda () (let ([v expr]) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 24504696..a7acecc3 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -127,6 +127,7 @@ (define (dispatch-all-ready) ;; in atomic mode (pre-event-sync #f) + (clean-up-destroyed) ;; Windows uses messages above #x4000 to hilite items in the task bar, ;; etc. In any case, these messages won't be handled by us, so they diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 30840da7..ce27d48f 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -18,9 +18,12 @@ failed GetLastError + DestroyWindow NotifyWindowDestroy CreateWindowExW + clean-up-destroyed + GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -73,6 +76,9 @@ #:wrap (deallocator)) (define NotifyWindowDestroy ((deallocator) void)) +(define (clean-up-destroyed) + (free-remembered-now DestroyWindow)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -80,7 +86,7 @@ _int _int _int _int _HWND _HMENU _HINSTANCE _pointer -> _HWND) - #:wrap (allocator DestroyWindow)) + #:wrap (allocator remember-to-free-later)) (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) From d55193a6f20afd96906a81f9c26b14c26dbef350 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 29 Oct 2010 15:10:54 -0600 Subject: [PATCH 340/462] cocoa: convince dock to not resurrect a closed frame original commit: 50caefcb3853f9b3e55673fb3a869e80225ccd1f --- collects/mred/private/wx/cocoa/frame.rkt | 32 ++++++++++++++++-------- collects/mred/private/wx/cocoa/queue.rkt | 4 +++ 2 files changed, 25 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 0edb644f..8d585a77 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -47,7 +47,7 @@ (let ([wx (->wx wxb)]) (and wx (not (other-modal? wx))))] - [-a _BOOL (canBecomeMainWindow) #t] + [-a _BOOL (canBecomeMainWindow) #t] [-a _BOOL (windowShouldClose: [_id win]) (queue-window*-event wxb (lambda (wx) (unless (other-modal? wx) @@ -73,15 +73,19 @@ (queue-window*-event wxb (lambda (wx) (send wx on-size 0 0))))] [-a _void (windowDidBecomeMain: [_id notification]) - (when wxb - (let ([wx (->wx wxb)]) - (when wx - (set! front wx) - (send wx install-wait-cursor) - (send wx install-mb) - (send wx notify-responder #t) - (queue-window-event wx (lambda () - (send wx on-activate #t))))))] + ;; We check whether the window is visible because + ;; clicking the dock item tries to resurrect a hidden + ;; frame. See also `setOneShot' below. + (when (tell #:type _BOOL self isVisible) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (set! front wx) + (send wx install-wait-cursor) + (send wx install-mb) + (send wx notify-responder #t) + (queue-window-event wx (lambda () + (send wx on-activate #t)))))))] [-a _void (windowDidResignMain: [_id notification]) (when wxb (let ([wx (->wx wxb)]) @@ -89,7 +93,9 @@ (when (eq? front wx) (set! front #f) (send wx uninstall-wait-cursor)) - (send empty-mb install) + (if root-fake-frame + (send root-fake-frame install-mb) + (send empty-mb install)) (send wx notify-responder #f) (queue-window-event wx (lambda () (send wx on-activate #f))))))] @@ -185,6 +191,10 @@ (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) + ;; Setting the window in one-shot mode helps prevent the + ;; frame from being resurrected by a click on the dock icon. + (tellv cocoa setOneShot: #:type _BOOL #t) + (define/override (get-cocoa-content) (tell cocoa contentView)) (define/override (get-cocoa-window) cocoa) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index aec434b5..6c9f005b 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -48,6 +48,10 @@ (super-tell #:type _BOOL validateMenuItem: menuItem))] [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) (queue-file-event (string->path filename))] + [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) + ;; If we have any visible windows, return #t to do the default thing. + ;; Otherwise return #f, because we don't want any invisible windows resurrected. + has-visible?] [-a _void (applicationDidChangeScreenParameters: notification) ;; Screen changes sometimes make the event loop get stuck; ;; hack: schedule a wake-up call in 5 seconds From ae528ecf8b13924e16ca516d76ec79faf1768295 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 30 Oct 2010 21:13:49 -0600 Subject: [PATCH 341/462] cocoa: hack around a problem with application hiding original commit: da6397e00657b85e3e6108ac69d5cb06cfaf45e2 --- collects/mred/private/wx/cocoa/queue.rkt | 41 ++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 6c9f005b..31eb3b60 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -61,8 +61,6 @@ ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly (void)]) -(tellv app finishLaunching) - ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive ;; keyboard events. @@ -95,6 +93,8 @@ (void (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) +(tellv app finishLaunching) + ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up @@ -189,6 +189,38 @@ [source (CFSocketCreateRunLoopSource (CFAllocatorGetDefault) cfs 0)]) (CFRunLoopAddSource rl source kCFRunLoopDefaultMode)) +;; ------------------------------------------------------------ +;; Another hack: +;; Install a run-loop observer that noticed when the core run loop +;; is exited multiple times during a single wait for a Cocoa event. +;; When that happens, it's a sign that something has gone wrong, +;; and we should interrupt the event wait and try again. This happens +;; when the user hides the application and then clicks on the dock +;; icon. (But why does that happen?) + +(define _Boolean _BOOL) +(define-cf kCFRunLoopCommonModes _pointer) +(define-cf CFRunLoopObserverCreate (_fun _pointer ; CFAllocatorRef + _int ; CFOptionFlags + _Boolean ; repeats? + _CFIndex ; order + (_fun #:atomic? #t _pointer _int _pointer -> _void) + _pointer ; CFRunLoopObserverContext + -> _pointer)) +(define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void)) +(define-cf CFRunLoopGetMain (_fun -> _pointer)) +(define kCFRunLoopExit (arithmetic-shift 1 7)) +(define-mz scheme_signal_received (_fun -> _void)) +(define already-exited? #f) +(define sleeping? #f) +(define (exiting-run-loop x y z) + (when sleeping? + (if already-exited? + (scheme_signal_received) + (set! already-exited? #t)))) +(let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)]) + (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes)) + ;; ------------------------------------------------------------ ;; Cocoa event pump @@ -330,9 +362,12 @@ ;; Called through an atomic callback: (define (sleep-until-event secs fds) + (set! sleeping? #t) + (set! already-exited? #f) (scheme_start_sleeper_thread scheme_sleep secs fds write_sock) (check-one-event #t #f) ; blocks until an event is ready - (scheme_end_sleeper_thread)) + (scheme_end_sleeper_thread) + (set! sleeping? #f)) (define (cocoa-install-event-wakeup) (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it From 161729f9388a8e7d7a849d2edceca2bdbc80b676 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 11:17:24 -0600 Subject: [PATCH 342/462] win32: change HWND allocation and deallocation original commit: daf7f6dd17c0f1d5544a489a68c46e377e0eca07 --- collects/mred/private/wx/win32/button.rkt | 31 ++-- collects/mred/private/wx/win32/canvas.rkt | 28 ++-- collects/mred/private/wx/win32/choice.rkt | 27 ++- collects/mred/private/wx/win32/gauge.rkt | 29 ++-- .../mred/private/wx/win32/group-panel.rkt | 22 ++- collects/mred/private/wx/win32/item.rkt | 16 -- collects/mred/private/wx/win32/list-box.rkt | 35 ++-- collects/mred/private/wx/win32/message.rkt | 35 ++-- collects/mred/private/wx/win32/radio-box.rkt | 32 ++-- collects/mred/private/wx/win32/slider.rkt | 23 ++- collects/mred/private/wx/win32/tab-panel.rkt | 23 ++- collects/mred/private/wx/win32/utils.rkt | 22 --- collects/mred/private/wx/win32/window.rkt | 5 - collects/mred/private/wx/win32/wndclass.rkt | 154 ++++++++++++++---- 14 files changed, 246 insertions(+), 236 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 0c3a2924..b492db36 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -21,7 +21,6 @@ (define base-button% (class item% (inherit set-control-font auto-size get-hwnd - subclass-control remember-label-bitmap) (init parent cb label x y w h style font) @@ -38,20 +37,20 @@ (super-new [callback cb] [parent parent] [hwnd - (CreateWindowExW 0 - (get-class) - (if (string? label) - label - "") - (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - BS_BITMAP - 0)) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)] + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] [style style]) (when bitmap? @@ -73,8 +72,6 @@ (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) (auto-size-button font label) - (subclass-control (get-hwnd)) - (define/override (is-command? cmd) (= cmd BN_CLICKED)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index f46c513b..dc222829 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -82,7 +82,6 @@ get-client-size get-eventspace set-control-font - subclass-control is-auto-scroll? get-virtual-width get-virtual-height reset-auto-scroll refresh-for-autoscroll @@ -122,18 +121,18 @@ #f)) (define combo-hwnd (and panel-hwnd - (CreateWindowExW 0 - "PLTCOMBOBOX" - "" - (bitwise-ior WS_CHILD WS_VISIBLE - CBS_DROPDOWNLIST - WS_HSCROLL WS_VSCROLL - WS_BORDER WS_CLIPSIBLINGS) - 0 0 w h - panel-hwnd - #f - hInstance - #f))) + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + "" + (bitwise-ior WS_CHILD WS_VISIBLE + CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 w h + panel-hwnd + #f + hInstance + #f))) (define hwnd (or panel-hwnd canvas-hwnd)) @@ -145,8 +144,7 @@ [style style]) (when combo-hwnd - (set-control-font #f combo-hwnd) - (subclass-control combo-hwnd)) + (set-control-font #f combo-hwnd)) (define control-border-theme (and (memq 'control-border style) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 940cca94..5eff9838 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -25,23 +25,22 @@ x y w h choices style font) (inherit auto-size set-control-font - set-size - subclass-control) + set-size) (define callback cb) (define hwnd - (CreateWindowExW 0 - "PLTCOMBOBOX" - label - (bitwise-ior WS_CHILD CBS_DROPDOWNLIST - WS_HSCROLL WS_VSCROLL - WS_BORDER WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + label + (bitwise-ior WS_CHILD CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define num-choices (length choices)) @@ -66,8 +65,6 @@ (set-size -11111 -11111 w (* h 8)))) - (subclass-control hwnd) - (define choice-dropped? #f) (define/override (ctlproc w msg wParam lParam default) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index d87bf8ce..6c92bd59 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -21,8 +21,7 @@ (define gauge% (class item% - (inherit set-size - subclass-control) + (inherit set-size) (init parent label @@ -32,18 +31,18 @@ font) (define hwnd - (CreateWindowExW 0 - "PLTmsctls_progress32" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS - (if (memq 'vertical style) - PBS_VERTICAL - 0)) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTmsctls_progress32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'vertical style) + PBS_VERTICAL + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (super-new [callback void] [parent parent] @@ -56,8 +55,6 @@ (set-size -11111 -11111 100 24) (set-size -11111 -11111 24 100)) - (subclass-control hwnd) - (define/public (get-value) (SendMessageW hwnd PBM_GETPOS 0 0)) (define/public (set-value v) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 3dce9e40..49398675 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -22,19 +22,18 @@ style label) - (inherit auto-size set-control-font - subclass-control) + (inherit auto-size set-control-font) (define hwnd - (CreateWindowExW 0 - "PLTBUTTON" - (or label "") - (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTBUTTON" + (or label "") + (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define client-hwnd (CreateWindowExW 0 @@ -63,7 +62,6 @@ (lambda (w h) (set! label-h h) (set-size -11111 -11111 (+ w 10) (+ h 10)))) - (subclass-control hwnd) (define/public (set-label lbl) (SetWindowTextW hwnd lbl)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 20477dd9..bc549375 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -16,17 +16,6 @@ (protect-out item-mixin item%)) -(define (control-proc w msg wParam lParam) - (let ([wx (hwnd->wx w)]) - (if wx - (send wx ctlproc w msg wParam lParam - (lambda (w msg wParam lParam) - ((hwnd->ctlproc w) w msg wParam lParam))) - (let ([default-ctlproc (hwnd->ctlproc w)]) - (default-ctlproc w msg wParam lParam))))) - -(define control_proc (function-ptr control-proc _WndProc)) - (define (item-mixin %) (class % (inherit on-set-focus @@ -40,11 +29,6 @@ (super-new) - (define/public (subclass-control hwnd) - (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) - (set-hwnd-ctlproc! hwnd old-control-proc) - (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) - (define/public (ctlproc w msg wParam lParam default) (if (try-mouse w msg wParam lParam) 0 diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 1ff72c98..df223e2f 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -54,7 +54,6 @@ font label-font) (inherit set-size set-control-font - subclass-control get-client-size) (define single? @@ -62,22 +61,22 @@ (not (memq 'mutiple style)))) (define hwnd - (CreateWindowExW WS_EX_CLIENTEDGE - "PLTLISTBOX" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY - WS_VSCROLL - (if (memq 'hscroll style) WS_HSCROLL 0) - (cond - ;; Win32 sense of "multiple" and "extended" is backwards - [(eq? kind 'extended) LBS_MULTIPLESEL] - [(eq? kind 'multiple) LBS_EXTENDEDSEL] - [else 0])) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control WS_EX_CLIENTEDGE + "PLTLISTBOX" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] + [else 0])) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (for ([s (in-list choices)]) (SendMessageW/str hwnd LB_ADDSTRING 0 s)) @@ -90,8 +89,6 @@ (set-control-font font) (set-size -11111 -11111 40 60) - (subclass-control hwnd) - (define callback cb) (define/override (is-command? cmd) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index e4ee583c..a140cbea 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -65,7 +65,6 @@ (define message% (class item% (inherit auto-size set-size set-control-font get-hwnd - subclass-control remember-label-bitmap) (init parent label @@ -81,26 +80,24 @@ (super-new [callback void] [parent parent] [hwnd - (CreateWindowExW 0 - (get-class) - (if (string? label) - label - "") - (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - SS_BITMAP - (if (symbol? label) - SS_ICON - 0))) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)] + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + SS_BITMAP + (if (symbol? label) + SS_ICON + 0))) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] [style style]) - (subclass-control (get-hwnd)) - (when bitmap? (let ([hbitmap (bitmap->hbitmap label)]) (remember-label-bitmap hbitmap) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 30453ffe..bb9c9de7 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -30,7 +30,6 @@ (inherit auto-size set-control-font is-enabled-to-root? - subclass-control set-focus) (define callback cb) @@ -59,20 +58,20 @@ [bitmap? (and (label . is-a? . bitmap%) (send label ok?))] [radio-hwnd - (CreateWindowExW 0 - "PLTBUTTON" - (if (string? label) - label - "") - (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - BS_BITMAP - 0)) - 0 0 0 0 - hwnd - #f - hInstance - #f)]) + (CreateWindowExW/control 0 + "PLTBUTTON" + (if (string? label) + label + "") + (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + hwnd + #f + hInstance + #f)]) (when bitmap? (let ([hbitmap (bitmap->hbitmap label)]) (set! label-bitmaps (cons hbitmap label-bitmaps)) @@ -96,9 +95,6 @@ [hwnd hwnd] [extra-hwnds radio-hwnds] [style style]) - - (for ([radio-hwnd (in-list radio-hwnds)]) - (subclass-control radio-hwnd)) (define/override (is-hwnd? a-hwnd) (or (ptr-equal? hwnd a-hwnd) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 05aafb36..efecc60d 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -40,8 +40,7 @@ style font) (inherit set-control-font - auto-size - subclass-control) + auto-size) (define callback cb) (define vertical? (memq 'vertical style)) @@ -79,15 +78,15 @@ (define value-hwnd (and panel-hwnd - (CreateWindowExW 0 - "STATIC" - (format "~s" val) - (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) - 0 0 0 0 - panel-hwnd - #f - hInstance - #f))) + (CreateWindowExW/control 0 + "STATIC" + (format "~s" val) + (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) + 0 0 0 0 + panel-hwnd + #f + hInstance + #f))) (define hwnd (or panel-hwnd slider-hwnd)) @@ -129,8 +128,6 @@ (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) (set-value val) - (subclass-control slider-hwnd) - (define/override (set-size x y w h) (super set-size x y w h) (when panel-hwnd diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 5ff10ba0..a85aaf96 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -45,19 +45,18 @@ (define callback void) (inherit auto-size set-control-font - is-shown-to-root? - subclass-control) + is-shown-to-root?) (define hwnd - (CreateWindowExW 0 - "PLTSysTabControl32" - "" - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTSysTabControl32" + "" + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define client-hwnd (CreateWindowExW 0 @@ -76,8 +75,6 @@ [hwnd hwnd] [style style]) - (subclass-control hwnd) - (define/override (get-client-hwnd) client-hwnd) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index ce27d48f..cc519e19 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -19,11 +19,6 @@ GetLastError - DestroyWindow - NotifyWindowDestroy - CreateWindowExW - clean-up-destroyed - GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -71,23 +66,6 @@ (error who "call failed (~s)" (GetLastError))) -(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) - -> (unless r (failed 'DestroyWindow))) - #:wrap (deallocator)) -(define NotifyWindowDestroy ((deallocator) void)) - -(define (clean-up-destroyed) - (free-remembered-now DestroyWindow)) - -(define-user32 CreateWindowExW (_wfun _DWORD - _string/utf-16 - _string/utf-16 - _UDWORD - _int _int _int _int - _HWND _HMENU _HINSTANCE _pointer - -> _HWND) - #:wrap (allocator remember-to-free-later)) - (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index c2b8b832..bcd94f97 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -143,11 +143,6 @@ (if (try-mouse w msg wParam lParam) 0 (cond - [(= msg WM_DESTROY) - ;; release immobile cell - (unregister-hwnd w) - ;; so it won't be finalized: - (NotifyWindowDestroy w)] [(= msg WM_SETFOCUS) (queue-window-event this (lambda () (on-set-focus))) 0] diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 4e3a62f1..c41a4943 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -1,7 +1,9 @@ #lang racket/base (require ffi/unsafe + ffi/unsafe/alloc racket/class "../../lock.rkt" + "../common/utils.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -12,11 +14,12 @@ DefWindowProcW background-hbrush set-hwnd-wx! - set-hwnd-ctlproc! hwnd->wx hwnd->ctlproc any-hwnd->wx - unregister-hwnd + CreateWindowExW + CreateWindowExW/control + clean-up-destroyed MessageBoxW _WndProc)) @@ -32,50 +35,69 @@ ;; | (cons ) ;; = (make-weak-box ) -(define all-cells (make-hash)) +(define all-hwnds (make-hash)) + +;; call in atomic mode: +(define (register-hwnd! hwnd) + (hash-set! all-hwnds (cast hwnd _pointer _long) #t)) + +;; call in atomic mode: +(define (alloc-hwnd-cell hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (or c + (let ([c (malloc-immobile-cell #f)]) + (SetWindowLongW hwnd GWLP_USERDATA c) + c)))) (define (set-hwnd-wx! hwnd wx) - (let ([c (malloc-immobile-cell (make-weak-box wx))]) - (SetWindowLongW hwnd GWLP_USERDATA c) - (atomically (hash-set! all-cells (cast c _pointer _long) #t)))) + (let* ([c (atomically (alloc-hwnd-cell hwnd))] + [v (ptr-ref c _racket)]) + (ptr-set! c _racket (cons wx (and v (cdr v)))))) (define (set-hwnd-ctlproc! hwnd ctlproc) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc)))) + (let* ([c (atomically (alloc-hwnd-cell hwnd))] + [v (ptr-ref c _racket)]) + (ptr-set! c _racket (cons (and v (car v)) ctlproc)))) (define (hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (let ([wb (ptr-ref p _racket)]) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([wb (ptr-ref c _racket)]) (and wb (weak-box-value (if (pair? wb) (car wb) wb))))))) (define (hwnd->ctlproc hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (let ([wb (ptr-ref p _racket)]) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([wb (ptr-ref c _racket)]) (and wb (pair? wb) (cdr wb)))))) (define (any-hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p - (atomically (hash-ref all-cells (cast p _pointer _long) #f)) - (let ([wx (let ([wb (ptr-ref p _racket)]) - (and wb - (weak-box-value (if (pair? wb) - (car wb) - wb))))]) - (and wx - (send wx is-hwnd? hwnd) - wx))))) + (and + (atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f)) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c + (let ([wx (let ([wb (ptr-ref c _racket)]) + (and wb + (weak-box-value (if (pair? wb) + (car wb) + wb))))]) + (and wx + (send wx is-hwnd? hwnd) + wx)))))) -(define (unregister-hwnd hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (when p - (free-immobile-cell p) - (SetWindowLongW hwnd GWLP_USERDATA #f)))) +;; call in atomic mode: +(define (unregister-hwnd? hwnd) + (let ([addr (cast hwnd _pointer _long)]) + (and (hash-ref all-hwnds addr #f) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (when c + (free-immobile-cell c) + (hash-ref all-hwnds addr #f) + (SetWindowLongW hwnd GWLP_USERDATA #f) + #t))))) ;; ---------------------------------------- @@ -95,6 +117,74 @@ (define _WndProc (_wfun #:atomic? #t #:keep (box null) _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define (wind-proc w msg wparam lparam) + (if (= msg WM_DESTROY) + (begin + (unregister-hwnd? w) + (DefWindowProcW w msg wparam lparam)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wparam lparam DefWindowProcW) + (DefWindowProcW w msg wparam lparam))))) + +(define wind-proc-ptr (function-ptr wind-proc _WndProc)) + +(define (control-proc w msg wParam lParam) + (if (= msg WM_DESTROY) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (unregister-hwnd? w) + (default-ctlproc w)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx ctlproc w msg wParam lParam + (lambda (w msg wParam lParam) + ((hwnd->ctlproc w) w msg wParam lParam))) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (default-ctlproc w msg wParam lParam)))))) + +(define control_proc (function-ptr control-proc _WndProc)) + +(define (subclass-control hwnd) + (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) + (set-hwnd-ctlproc! hwnd old-control-proc) + (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) + +;; ---------------------------------------- + +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow)))) + +(define (maybe-destroy-window hwnd) + (atomically + (when (unregister-hwnd? hwnd) + (DestroyWindow hwnd)))) + +(define (clean-up-destroyed) + (free-remembered-now maybe-destroy-window)) + +(define-user32 _CreateWindowExW (_wfun _DWORD + _string/utf-16 + _string/utf-16 + _UDWORD + _int _int _int _int + _HWND _HMENU _HINSTANCE _pointer + -> _HWND) + #:c-id CreateWindowExW) + +(define (make-CreateWindowEx register!) + ((allocator remember-to-free-later) + (lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam) + (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)]) + (register-hwnd! hwnd) + hwnd)))) + +(define CreateWindowExW (make-CreateWindowEx register-hwnd!)) +(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd) + (register-hwnd! hwnd) + (subclass-control hwnd)))) + +;; ---------------------------------------- + (define-cstruct _WNDCLASS ([style _UINT] [lpfnWndProc _fpointer] [cbClsExtra _int] @@ -120,14 +210,6 @@ #;(define-user32 PostQuitMessage (_wfun _int -> _void)) -(define (wind-proc w msg wparam lparam) - (let ([wx (hwnd->wx w)]) - (if wx - (send wx wndproc w msg wparam lparam DefWindowProcW) - (DefWindowProcW w msg wparam lparam)))) - -(define wind-proc-ptr (function-ptr wind-proc _WndProc)) - (define hInstance (GetModuleHandleW #f)) (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) From 2f62b2ae628c9b8ff1c458722438002a624cc134 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 11:32:05 -0600 Subject: [PATCH 343/462] win32: further deallocation fixes, plus some test fixes original commit: ad9315ba6bc4646630005a3f22d0e8c8f54beff6 --- collects/mred/private/wx/win32/canvas.rkt | 22 +++++++----- collects/mred/private/wx/win32/choice.rkt | 2 +- collects/mred/private/wx/win32/list-box.rkt | 28 +++++++-------- collects/mred/private/wx/win32/wndclass.rkt | 38 ++++++++++----------- 4 files changed, 47 insertions(+), 43 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index dc222829..759b4c40 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -330,15 +330,21 @@ (GetScrollPos canvas-hwnd SB_VERT)) (define/public (get-scroll-pos which) - (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) + (if (is-auto-scroll?) + 0 + (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))) (define/public (get-scroll-range which) - (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (+ (- (SCROLLINFO-nMax i) - (SCROLLINFO-nPage i)) - 1))) + (if (is-auto-scroll?) + 0 + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (+ (- (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i)) + 1)))) (define/public (get-scroll-page which) - (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (SCROLLINFO-nPage i))) + (if (is-auto-scroll?) + 0 + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (SCROLLINFO-nPage i)))) (define/public (set-scroll-pos which v) (void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) @@ -445,7 +451,7 @@ (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/public (set-resize-corner on?) (void)) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 5eff9838..4a045e7a 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -94,7 +94,7 @@ (define/public (set-selection i) - (SendMessageW hwnd CB_SETCURSEL i 0)) + (void (SendMessageW hwnd CB_SETCURSEL i 0))) (define/public (get-selection) (SendMessageW hwnd CB_GETCURSEL 0 0)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index df223e2f..9510d8e3 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -56,9 +56,7 @@ (inherit set-size set-control-font get-client-size) - (define single? - (and (not (memq 'extended style)) - (not (memq 'mutiple style)))) + (define single? (eq? 'single kind)) (define hwnd (CreateWindowExW/control WS_EX_CLIENTEDGE @@ -115,10 +113,11 @@ (define/public (set-string i str) (atomically (SendMessageW/str hwnd LB_INSERTSTRING i str) - (SendMessageW hwnd LB_DELETESTRING (add1 i) 0))) + (SendMessageW hwnd LB_DELETESTRING (add1 i) 0) + (void))) (define/public (set-first-visible-item i) - (SendMessageW hwnd LB_SETTOPINDEX i 0)) + (void (SendMessageW hwnd LB_SETTOPINDEX i 0))) (define/public (get-first-item) (SendMessageW hwnd LB_GETTOPINDEX 0 0)) @@ -134,7 +133,7 @@ (atomically (set! data null) (set! num 0) - (SendMessageW hwnd LB_RESETCONTENT 0 0))) + (void (SendMessageW hwnd LB_RESETCONTENT 0 0)))) (define/public (set choices) (atomically @@ -157,7 +156,7 @@ (atomically (set! data (append (take data i) (drop data (add1 i)))) (set! num (sub1 num)) - (SendMessageW hwnd LB_DELETESTRING i 0))) + (void (SendMessageW hwnd LB_DELETESTRING i 0)))) (define/public (get-selections) (atomically @@ -186,14 +185,15 @@ (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) (define/public (select i [on? #t] [extend? #t]) - (if single? - (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) - (begin - (when extend? - (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) - (SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))) + (void + (if single? + (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) + (begin + (when extend? + (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) + (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))) (define/public (set-selection i) - (select i #t #f)) + (void (select i #t #f))) (def/public-unimplemented get-label-font))) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index c41a4943..1f0da158 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -39,7 +39,7 @@ ;; call in atomic mode: (define (register-hwnd! hwnd) - (hash-set! all-hwnds (cast hwnd _pointer _long) #t)) + (hash-set! all-hwnds (cast hwnd _pointer _long) hwnd)) ;; call in atomic mode: (define (alloc-hwnd-cell hwnd) @@ -52,27 +52,26 @@ (define (set-hwnd-wx! hwnd wx) (let* ([c (atomically (alloc-hwnd-cell hwnd))] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons wx (and v (cdr v)))))) + (ptr-set! c _racket (cons (make-weak-box wx) + (and v (cdr v)))))) (define (set-hwnd-ctlproc! hwnd ctlproc) (let* ([c (atomically (alloc-hwnd-cell hwnd))] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (and v (car v)) ctlproc)))) + (ptr-set! c _racket (cons (and v (car v)) + ctlproc)))) (define (hwnd->wx hwnd) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (and c (let ([wb (ptr-ref c _racket)]) (and wb - (weak-box-value (if (pair? wb) - (car wb) - wb))))))) + (car wb) + (weak-box-value (car wb))))))) (define (hwnd->ctlproc hwnd) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (and c (let ([wb (ptr-ref c _racket)]) - (and wb - (pair? wb) - (cdr wb)))))) + (and wb (cdr wb)))))) (define (any-hwnd->wx hwnd) (and @@ -81,23 +80,22 @@ (and c (let ([wx (let ([wb (ptr-ref c _racket)]) (and wb - (weak-box-value (if (pair? wb) - (car wb) - wb))))]) + (car wb) + (weak-box-value (car wb))))]) (and wx (send wx is-hwnd? hwnd) wx)))))) ;; call in atomic mode: -(define (unregister-hwnd? hwnd) +(define (unregister-hwnd? hwnd [same? (lambda (v) (eq? v hwnd))]) (let ([addr (cast hwnd _pointer _long)]) - (and (hash-ref all-hwnds addr #f) + (and (same? (hash-ref all-hwnds addr #f)) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (when c (free-immobile-cell c) - (hash-ref all-hwnds addr #f) - (SetWindowLongW hwnd GWLP_USERDATA #f) - #t))))) + (SetWindowLongW hwnd GWLP_USERDATA #f)) + (hash-remove! all-hwnds addr) + #t)))) ;; ---------------------------------------- @@ -120,7 +118,7 @@ (define (wind-proc w msg wparam lparam) (if (= msg WM_DESTROY) (begin - (unregister-hwnd? w) + (unregister-hwnd? w (lambda (x) x)) (DefWindowProcW w msg wparam lparam)) (let ([wx (hwnd->wx w)]) (if wx @@ -132,7 +130,7 @@ (define (control-proc w msg wParam lParam) (if (= msg WM_DESTROY) (let ([default-ctlproc (hwnd->ctlproc w)]) - (unregister-hwnd? w) + (unregister-hwnd? w (lambda (x) x)) (default-ctlproc w)) (let ([wx (hwnd->wx w)]) (if wx @@ -175,7 +173,7 @@ ((allocator remember-to-free-later) (lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam) (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)]) - (register-hwnd! hwnd) + (register! hwnd) hwnd)))) (define CreateWindowExW (make-CreateWindowEx register-hwnd!)) From c2ce22a9b7c574e121de2ca583aa6bc7aca0e050 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 19:42:39 -0600 Subject: [PATCH 344/462] win32: further deallocation fixes, plus some test fixes original commit: f8294247833a45371a62a3ac050069e1b3c3bcb1 --- collects/mred/private/wx/win32/dialog.rkt | 22 +-- collects/mred/private/wx/win32/slider.rkt | 32 ++-- collects/mred/private/wx/win32/types.rkt | 2 + collects/mred/private/wx/win32/wndclass.rkt | 160 ++++++++++++-------- 4 files changed, 115 insertions(+), 101 deletions(-) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index b3e8a887..c249f2f9 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -28,27 +28,8 @@ [class _short] ; 0 [title _short])) ; 0 -(define _INT_PTR _long) -(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) - - (define DS_MODALFRAME #x80) -(define-user32 CreateDialogIndirectParamW (_wfun _HINSTANCE - _DLGTEMPLATE-pointer - _HWND - _fpointer - -> _HWND)) - -(define (dlgproc w msg wParam lParam) - (let ([wx (hwnd->wx w)]) - (if wx - (send wx wndproc w msg wParam lParam - (lambda (w msg wParam lParam) 0)) - 0))) - -(define dialog-proc (function-ptr dlgproc _DialogProc)) - (define dialog% (class (dialog-mixin frame%) (super-new) @@ -62,7 +43,8 @@ 0 0 w h 0 0 0) (and parent (send parent get-hwnd)) - dialog-proc)]) + dialog-proc + 0)]) (SetWindowTextW hwnd label) (MoveWindow hwnd 0 0 w h #t) hwnd)) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index efecc60d..6f003c63 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -59,22 +59,22 @@ #f))) (define slider-hwnd - (CreateWindowExW 0 - "PLTmsctls_trackbar32" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS - (if vertical? - TBS_VERT - TBS_HORZ) - (if panel-hwnd - WS_VISIBLE - 0)) - 0 0 0 0 - (or panel-hwnd - (send parent get-client-hwnd)) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTmsctls_trackbar32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if vertical? + TBS_VERT + TBS_HORZ) + (if panel-hwnd + WS_VISIBLE + 0)) + 0 0 0 0 + (or panel-hwnd + (send parent get-client-hwnd)) + #f + hInstance + #f)) (define value-hwnd (and panel-hwnd diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 1ef78ccf..cc29d864 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -21,6 +21,7 @@ _HRESULT _WCHAR _SIZE_T + _INT_PTR _HINSTANCE _HWND @@ -66,6 +67,7 @@ (define _HRESULT _int32) (define _WCHAR _int16) (define _SIZE_T _long) +(define _INT_PTR _intptr) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 1f0da158..378aa3be 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -19,6 +19,7 @@ any-hwnd->wx CreateWindowExW CreateWindowExW/control + CreateDialogIndirectParamW dialog-proc clean-up-destroyed MessageBoxW _WndProc)) @@ -29,73 +30,63 @@ ;; The weak pointer must be wrapped in an immuable cell. ;; In addition, if we need to save a control's old ;; ctlproc, we put it in the same immutable cell. -;; So: -;; = (make-immutable-cell ) -;; = -;; | (cons ) -;; = (make-weak-box ) (define all-hwnds (make-hash)) ;; call in atomic mode: (define (register-hwnd! hwnd) - (hash-set! all-hwnds (cast hwnd _pointer _long) hwnd)) - -;; call in atomic mode: -(define (alloc-hwnd-cell hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (or c - (let ([c (malloc-immobile-cell #f)]) - (SetWindowLongW hwnd GWLP_USERDATA c) - c)))) - + (hash-set! all-hwnds (cast hwnd _pointer _long) #t) + (let ([c (malloc-immobile-cell (vector #f #f #f))]) + (void (SetWindowLongW hwnd GWLP_USERDATA c)))) + (define (set-hwnd-wx! hwnd wx) - (let* ([c (atomically (alloc-hwnd-cell hwnd))] + (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (make-weak-box wx) - (and v (cdr v)))))) + (vector-set! v 0 (make-weak-box wx)))) -(define (set-hwnd-ctlproc! hwnd ctlproc) - (let* ([c (atomically (alloc-hwnd-cell hwnd))] +(define (set-hwnd-ctlproc! hwnd save-ptr ctlproc) + (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (and v (car v)) - ctlproc)))) + (vector-set! v 1 ctlproc) + (vector-set! v 2 save-ptr))) (define (hwnd->wx hwnd) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (and c (let ([wb (ptr-ref c _racket)]) - (and wb - (car wb) - (weak-box-value (car wb))))))) - -(define (hwnd->ctlproc hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (and c (let ([wb (ptr-ref c _racket)]) - (and wb (cdr wb)))))) + (and c (let ([v (ptr-ref c _racket)]) + (and v + (let ([wb (vector-ref v 0)]) + (and wb + (weak-box-value wb)))))))) (define (any-hwnd->wx hwnd) (and (atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f)) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (and c - (let ([wx (let ([wb (ptr-ref c _racket)]) - (and wb - (car wb) - (weak-box-value (car wb))))]) - (and wx - (send wx is-hwnd? hwnd) - wx)))))) + (let ([wx (hwnd->wx hwnd)]) + (and wx + (send wx is-hwnd? hwnd) + wx)))) + +(define (hwnd->ctlproc hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 1)))))) + +(define (hwnd->ctlproc-fptr hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 2)))))) ;; call in atomic mode: -(define (unregister-hwnd? hwnd [same? (lambda (v) (eq? v hwnd))]) - (let ([addr (cast hwnd _pointer _long)]) - (and (same? (hash-ref all-hwnds addr #f)) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (when c - (free-immobile-cell c) - (SetWindowLongW hwnd GWLP_USERDATA #f)) - (hash-remove! all-hwnds addr) - #t)))) +(define (can-unregister-hwnd? hwnd) + (hash-ref all-hwnds (cast hwnd _pointer _long) #f)) + +;; call in atomic mode: +(define (unregister-hwnd! hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (when c + (free-immobile-cell c) + (SetWindowLongW hwnd GWLP_USERDATA #f)) + (hash-remove! all-hwnds (cast hwnd _pointer _long)))) ;; ---------------------------------------- @@ -118,7 +109,7 @@ (define (wind-proc w msg wparam lparam) (if (= msg WM_DESTROY) (begin - (unregister-hwnd? w (lambda (x) x)) + (unregister-hwnd! w) (DefWindowProcW w msg wparam lparam)) (let ([wx (hwnd->wx w)]) (if wx @@ -128,25 +119,43 @@ (define wind-proc-ptr (function-ptr wind-proc _WndProc)) (define (control-proc w msg wParam lParam) - (if (= msg WM_DESTROY) - (let ([default-ctlproc (hwnd->ctlproc w)]) - (unregister-hwnd? w (lambda (x) x)) - (default-ctlproc w)) - (let ([wx (hwnd->wx w)]) - (if wx - (send wx ctlproc w msg wParam lParam - (lambda (w msg wParam lParam) - ((hwnd->ctlproc w) w msg wParam lParam))) - (let ([default-ctlproc (hwnd->ctlproc w)]) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (if (= msg WM_DESTROY) + (begin + (SetWindowLongW w GWLP_WNDPROC (hwnd->ctlproc-fptr w)) + (unregister-hwnd! w) + (default-ctlproc w msg wParam lParam)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx ctlproc w msg wParam lParam + (lambda (w msg wParam lParam) + (default-ctlproc w msg wParam lParam))) (default-ctlproc w msg wParam lParam)))))) (define control_proc (function-ptr control-proc _WndProc)) (define (subclass-control hwnd) - (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) - (set-hwnd-ctlproc! hwnd old-control-proc) + (let* ([fptr (GetWindowLongW hwnd GWLP_WNDPROC)] + [old-control-proc (function-ptr fptr _WndProc)]) + (set-hwnd-ctlproc! hwnd fptr old-control-proc) (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) + +(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) + +(define (dlgproc w msg wParam lParam) + (if (= msg WM_DESTROY) + (begin + (unregister-hwnd! w) + 0) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wParam lParam + (lambda (w msg wParam lParam) 0)) + 0)))) + +(define dialog-proc (function-ptr dlgproc _DialogProc)) + ;; ---------------------------------------- (define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) @@ -154,7 +163,7 @@ (define (maybe-destroy-window hwnd) (atomically - (when (unregister-hwnd? hwnd) + (when (can-unregister-hwnd? hwnd) (DestroyWindow hwnd)))) (define (clean-up-destroyed) @@ -171,8 +180,12 @@ (define (make-CreateWindowEx register!) ((allocator remember-to-free-later) - (lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam) - (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)]) + (lambda (dwExStyle lpClassName lpWindowName dwStyle + x y nWidth nHeight + hWndParent hMenu hInstance lpParam) + (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle + x y nWidth nHeight + hWndParent hMenu hInstance lpParam)]) (register! hwnd) hwnd)))) @@ -181,6 +194,23 @@ (register-hwnd! hwnd) (subclass-control hwnd)))) + +(define-user32 _CreateDialogIndirectParamW (_wfun _HINSTANCE + _pointer ; _DLGTEMPLATE-pointer + _HWND + _fpointer + _LPARAM + -> _HWND) + #:c-id CreateDialogIndirectParamW) + +(define CreateDialogIndirectParamW + ((allocator remember-to-free-later) + (lambda (hInstance lpTemplate hWndParent lpDialogFunc lParamInit) + (let ([hwnd (_CreateDialogIndirectParamW + hInstance lpTemplate hWndParent lpDialogFunc lParamInit)]) + (register-hwnd! hwnd) + hwnd)))) + ;; ---------------------------------------- (define-cstruct _WNDCLASS ([style _UINT] From 37e47fcddae0fa559f8584af9239972c55f1ce41 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 09:38:57 -0600 Subject: [PATCH 345/462] cocoa & gtk: fix some test failures original commit: e033d9edf157e015103a9652cea70c803990e3a0 --- collects/mred/private/wx/cocoa/canvas.rkt | 7 ++++--- collects/mred/private/wx/cocoa/list-box.rkt | 7 ++++++- collects/mred/private/wx/gtk/canvas.rkt | 21 ++++++++++++++++----- collects/mred/private/wx/win32/canvas.rkt | 11 ++++++----- collects/tests/gracket/windowing.rktl | 5 +++-- 5 files changed, 35 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index ee897ce3..4add0ce9 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -712,9 +712,10 @@ in-menu-click?) (define/public (scroll x y) - (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) - (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) - (when (is-auto-scroll?) (refresh-for-autoscroll))) + (when (is-auto-scroll?) + (when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller))))) + (when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller))))) + (refresh-for-autoscroll))) (define/public (warp-pointer x y) (void)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 72419a0e..0c8828ba 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -116,7 +116,12 @@ cell-font) (define/public (get-selection) - (tell #:type _NSInteger content-cocoa selectedRow)) + (if allow-multi? + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l))) + (tell #:type _NSInteger content-cocoa selectedRow))) (define/public (get-selections) (atomically (with-autorelease diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index bbc494d0..2de985ba 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -542,11 +542,22 @@ (define/public (on-scroll e) (void)) (define/public (scroll x y) - (as-scroll-change - (lambda () - (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) - (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)))) - (when (is-auto-scroll?) (refresh-for-autoscroll))) + (when (is-auto-scroll?) + (as-scroll-change + (lambda () + (when (and hscroll-adj (>= x 0)) + (gtk_adjustment_set_value + hscroll-adj + (floor + (* x (- (gtk_adjustment_get_upper hscroll-adj) + (gtk_adjustment_get_page_size hscroll-adj)))))) + (when (and vscroll-adj (>= y 0)) + (gtk_adjustment_set_value + vscroll-adj + (floor + (* y (- (gtk_adjustment_get_upper vscroll-adj) + (gtk_adjustment_get_page_size vscroll-adj)))))))) + (refresh-for-autoscroll))) (define/public (warp-pointer x y) (void)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 759b4c40..b222663b 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -445,11 +445,12 @@ (ptr-equal? combo-hwnd a-hwnd))) (define/public (scroll x y) - (when (x . > . 0) - (set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal))))) - (when (y . > . 0) - (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) - (when (is-auto-scroll?) (refresh-for-autoscroll))) + (when (is-auto-scroll?) + (when (x . > . 0) + (set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal))))) + (when (y . > . 0) + (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) + (refresh-for-autoscroll))) (define/public (warp-pointer x y) (void)) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index d6e2120e..52f0f245 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -56,6 +56,7 @@ (define (client->screen-tests f) (printf "Client<->Screen ~a\n" f) + (send (or (send f get-parent) f) reflow-container) (let-values ([(x y) (send f client->screen 0 0)]) (stvals '(0 0) f screen->client x y)) (let-values ([(x y) (send f screen->client 0 0)]) @@ -885,8 +886,8 @@ (lambda (xpos ypos) (let-values ([(x y) (send c get-view-start)]) (let ([coerce (lambda (x) (inexact->exact (floor x)))]) - (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x) - (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))]) + (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw ,w) x) + (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch , h) y))))]) (test 500 'canvas-virt-w-size w) (test 606 'canvas-virt-h-size h) From a8a54a110795da7ea2c2c299121b69b386b3e175 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 19:58:48 -0600 Subject: [PATCH 346/462] win32: fix some test failures original commit: 9fbb7d3a9927a828cc26032bb981b03e47f72a5e --- collects/mred/private/wx/win32/canvas.rkt | 29 +++++++++++++-------- collects/mred/private/wx/win32/list-box.rkt | 4 +-- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index b222663b..6bc0803a 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -318,7 +318,8 @@ (when hscroll? (SetScrollInfo canvas-hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) (when vscroll? - (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) + (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)) + (void)) (define/override (reset-dc-for-autoscroll) (reset-dc) @@ -336,10 +337,12 @@ (define/public (get-scroll-range which) (if (is-auto-scroll?) 0 - (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (+ (- (SCROLLINFO-nMax i) - (SCROLLINFO-nPage i)) - 1)))) + (get-real-scroll-range which))) + (define/public (get-real-scroll-range which) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (+ (- (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i)) + 1))) (define/public (get-scroll-page which) (if (is-auto-scroll?) 0 @@ -357,7 +360,8 @@ SIF_DISABLENOSCROLL 0))) (set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1)) - (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t) + (void))) (define/public (set-scroll-page which v) (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE @@ -369,7 +373,8 @@ (set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) v)) (set-SCROLLINFO-nPage! i v) - (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t) + (void))) (define/public (on-scroll e) (void)) (define/private (on-scroll-change dir part) @@ -446,10 +451,12 @@ (define/public (scroll x y) (when (is-auto-scroll?) - (when (x . > . 0) - (set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal))))) - (when (y . > . 0) - (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) + (when (x . >= . 0) + (set-scroll-pos 'horizontal + (->long (* x (get-real-scroll-range 'horizontal))))) + (when (y . >= . 0) + (set-scroll-pos 'vertical + (->long (* y (get-real-scroll-range 'vertical))))) (refresh-for-autoscroll))) (define/public (warp-pointer x y) (void)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 9510d8e3..8f572f54 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -184,12 +184,12 @@ (define/public (selected? i) (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) - (define/public (select i [on? #t] [extend? #t]) + (define/public (select i [on? #t] [one? #t]) (void (if single? (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) (begin - (when extend? + (unless one? (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))) From 303034be6fa8722b9416defb374d8c8c406372d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Nov 2010 07:58:23 -0600 Subject: [PATCH 347/462] gtk: periodic canvas flushing original commit: 72a19d2ab37e2e96974eb3dcf80fc39f3896a11a --- collects/mred/private/wx/cocoa/canvas.rkt | 12 ++++++++-- .../mred/private/wx/common/canvas-mixin.rkt | 24 ++++++++++++++++++- collects/mred/private/wx/common/queue.rkt | 4 +++- collects/mred/private/wx/gtk/canvas.rkt | 19 +++++++++++---- collects/mred/private/wx/gtk/queue.rkt | 10 ++++---- collects/mred/private/wx/win32/canvas.rkt | 12 ++++++++-- 6 files changed, 66 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 4add0ce9..7abf4dea 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -279,12 +279,20 @@ (queue-window-refresh-event this thunk)) (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) - (if is-combo? 2 0) (if is-combo? 2 0)) + (or (do-canvas-backing-flush #f) (begin (queue-paint) #f))) + (define/public (do-canvas-backing-flush ctx) + (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0))) + + ;; not used, because Cocoa canvas refreshes do not go through + ;; the eventspace queue: + (define/public (schedule-periodic-backing-flush) + (void)) + (define/public (begin-refresh-sequence) (send dc suspend-flush)) (define/public (end-refresh-sequence) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 2822e41e..1dbeb28e 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/draw + "../common/queue.rkt" "backing-dc.rkt") (provide @@ -162,7 +163,28 @@ (define/override (paint-children) (when (or paint-queued (not (send (get-dc) can-backing-flush?))) - (do-on-paint #f #f))))) + (do-on-paint #f #f))) + + + (define flush-box #f) + + ;; Periodic flush is needed for Windows and Gtk, where + ;; updates otherwise happen only via the eventspace's queue + (define/override (schedule-periodic-backing-flush) + (unless flush-box + (set! flush-box (box #t)) + (add-event-boundary-sometimes-callback! + flush-box + (lambda (b) + (when (unbox b) + (do-canvas-backing-flush #f)))))) + + (define/override (do-canvas-backing-flush ctx) + ;; cancel scheduled flush, if any: + (when flush-box + (set-box! flush-box #f) + (set! flush-box #f)) + (super do-canvas-backing-flush ctx)))) ;; useful for fixing the size of a collecting blit: (define (fix-bitmap-size on w h on-x on-y) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2d0e5776..687d5122 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -18,6 +18,7 @@ remove-event-boundary-callback! pre-event-sync boundary-tasks-ready-evt + sometimes-delay-msec eventspace? current-eventspace @@ -127,11 +128,12 @@ (alert-tasks-ready))) (define last-time -inf.0) +(define sometimes-delay-msec 50) ;; Call this function only in atomic mode: (define (pre-event-sync force?) (let ([now (current-inexact-milliseconds)]) - (when (or (now . > . (+ last-time 200)) + (when (or (now . > . (+ last-time sometimes-delay-msec)) force?) (set! last-time now) (hash-for-each sometimes-boundary-ht diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 2de985ba..94265bb9 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -352,15 +352,22 @@ (queue-window-refresh-event this thunk)) (define/public (paint-or-queue-paint) + ;; in atomic mode (if for-gl? (queue-paint) - (or (do-backing-flush this dc (if is-combo? - (get-subwindow client-gtk) - (widget-window client-gtk))) + (or (do-canvas-backing-flush #f) (begin (queue-paint) #f)))) + ;; overridden to extend for scheduled periodic flushes: + (define/public (schedule-periodic-backing-flush) + (void)) + (define/public (do-canvas-backing-flush ctx) + (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (widget-window client-gtk)))) + (define/public (on-paint) (void)) (define/public (get-flush-window) client-gtk) @@ -374,9 +381,11 @@ (queue-paint)) (define/public (queue-backing-flush) - ;; called atomically (not expecting exceptions) + ;; called atomically (unless for-gl? - (gtk_widget_queue_draw client-gtk))) + (gtk_widget_queue_draw client-gtk) + ;; peridodically flush to the screen: + (schedule-periodic-backing-flush))) (define/override (reset-child-dcs) (when (dc . is-a? . dc%) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index e42d3100..a37d81eb 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -194,10 +194,12 @@ (thread (lambda () (let loop () (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) - (sync queue-evt (if any-tasks? - (wrap-evt (system-idle-evt) - (lambda (v) #f)) - boundary-tasks-ready-evt))) + (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001)) + queue-evt + (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) (pre-event-sync #t)) (atomically (dispatch-all-ready)) (loop))))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 6bc0803a..46fa3308 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -168,7 +168,7 @@ (FillRect hdc r hbrush)) (unless transparent? (DeleteObject hbrush))) - (unless (do-backing-flush this dc hdc) + (unless (do-canvas-backing-flush hdc) (queue-paint))))) (EndPaint hdc ps)) 0] @@ -257,7 +257,15 @@ (define/public (queue-backing-flush) (unless for-gl? - (InvalidateRect canvas-hwnd #f #f))) + (InvalidateRect canvas-hwnd #f #f) + (schedule-periodic-backing-flush))) + + ;; overridden to extend for scheduled periodic flushes: + (define/public (schedule-periodic-backing-flush) + (void)) + (define/public (do-canvas-backing-flush hdc) + (when hdc + (do-backing-flush this dc hdc))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) From 64829783630e90c574fc94d24ef3298c8ceef27b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Nov 2010 08:09:42 -0600 Subject: [PATCH 348/462] win32: periodic canvas flushing original commit: 4d316f78510aed0ff5a90dd038994c6da0eaabda --- collects/mred/private/wx/common/queue.rkt | 8 ++++---- collects/mred/private/wx/win32/canvas.rkt | 7 +++++-- collects/mred/private/wx/win32/queue.rkt | 10 +++++++++- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 687d5122..61e6832c 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -112,14 +112,14 @@ (define (add-event-boundary-callback! v proc) (atomically - (alert-tasks-ready) - (hash-set! boundary-ht v proc))) + (hash-set! boundary-ht v proc) + (alert-tasks-ready))) (define (add-event-boundary-sometimes-callback! v proc) (atomically - (alert-tasks-ready) (when (zero? (hash-count sometimes-boundary-ht)) (set! last-time (current-inexact-milliseconds))) - (hash-set! sometimes-boundary-ht v proc))) + (hash-set! sometimes-boundary-ht v proc) + (alert-tasks-ready))) (define (remove-event-boundary-callback! v) (atomically diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 46fa3308..2dc6d0a1 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -264,8 +264,11 @@ (define/public (schedule-periodic-backing-flush) (void)) (define/public (do-canvas-backing-flush hdc) - (when hdc - (do-backing-flush this dc hdc))) + (if hdc + (do-backing-flush this dc hdc) + (let ([hdc (GetDC canvas-hwnd)]) + (do-backing-flush this dc hdc) + (ReleaseDC canvas-hwnd hdc)))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index a7acecc3..e1c194c3 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -146,6 +146,14 @@ (define (win32-start-event-pump) (thread (lambda () (let loop () - (sync queue-evt other-peek-evt) + (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) + (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001)) + queue-evt + other-peek-evt + (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) + (pre-event-sync #t)) (as-entry dispatch-all-ready) (loop))))) From 929595edaf93b80e23695c9b22d3bd7e0d743bd3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Nov 2010 16:01:15 -0600 Subject: [PATCH 349/462] win32: fix flush and periodic canvas flush original commit: 64d9a391cfe480fd599910026294cff62cd75ca3 --- collects/mred/private/wx/win32/canvas.rkt | 8 +++++++- collects/mred/private/wx/win32/procs.rkt | 3 +-- collects/mred/private/wx/win32/utils.rkt | 3 +++ collects/mred/private/wx/win32/window.rkt | 7 ++++++- 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 2dc6d0a1..3b9316a4 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -252,6 +252,11 @@ (define/public (end-refresh-sequence) (send dc resume-flush)) + ;; Improve this method to flush locally + ;; instead of globally: + (define/public (flush) + (flush-display)) + (define/public (on-paint) (void)) (define/override (refresh) (queue-paint)) @@ -268,7 +273,8 @@ (do-backing-flush this dc hdc) (let ([hdc (GetDC canvas-hwnd)]) (do-backing-flush this dc hdc) - (ReleaseDC canvas-hwnd hdc)))) + (ReleaseDC canvas-hwnd hdc) + (ValidateRect canvas-hwnd #f)))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 331b9dbf..8ec87a93 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -35,7 +35,6 @@ get-control-font-size get-control-font-size-in-pixels? cancel-quit - flush-display bell hide-cursor get-display-depth @@ -44,6 +43,7 @@ get-highlight-background-color get-highlight-text-color check-for-break) + flush-display fill-private-color play-sound location->window @@ -84,7 +84,6 @@ (define (get-control-font-face) (get-theme-font-face)) (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) -(define (flush-display) (void)) (define-user32 MessageBeep (_wfun _UINT -> _BOOL)) (define (bell) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index cc519e19..f100116b 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -36,6 +36,7 @@ GetDC ReleaseDC InvalidateRect + ValidateRect GetMenuState CheckMenuItem ModifyMenuW @@ -121,6 +122,8 @@ (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) -> (unless r (failed 'InvalidateRect)))) +(define-user32 ValidateRect (_wfun _HWND (_or-null _RECT-pointer) -> (r : _BOOL) + -> (unless r (failed 'ValidateRect)))) (define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT)) (define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index bcd94f97..caca412b 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -24,6 +24,7 @@ queue-window-event queue-window-refresh-event location->window + flush-display GetWindowRect GetClientRect)) @@ -700,4 +701,8 @@ (and hwnd (or (let ([wx (any-hwnd->wx hwnd)]) (and wx (send wx get-top-frame))) - (loop (GetParent hwnd))))))) \ No newline at end of file + (loop (GetParent hwnd))))))) + +(define (flush-display) + (atomically + (pre-event-sync #t))) From 7d3393f07f9f86e59d43c89a8ba2cacd00c78a10 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Nov 2010 16:02:03 -0600 Subject: [PATCH 350/462] gtk and cocoa: add flush method to canvas% and fix periodic flush original commit: b9f3957a767f3530f8a1e27a7be8ca4852e581f9 --- collects/mred/private/mrcanvas.rkt | 1 + collects/mred/private/wx/cocoa/dc.rkt | 3 ++ collects/mred/private/wx/cocoa/queue.rkt | 1 + collects/mred/private/wx/gtk/canvas.rkt | 14 ++++++--- collects/mred/private/wx/gtk/dc.rkt | 3 ++ collects/mred/private/wx/win32/canvas.rkt | 5 ++++ collects/mred/private/wx/win32/dc.rkt | 3 ++ collects/scribblings/gui/canvas-class.scrbl | 22 +------------- collects/scribblings/gui/canvas-intf.scrbl | 29 +++++++++++++++++++ .../scribblings/gui/global-draw-funcs.scrbl | 10 ++++--- doc/release-notes/racket/Draw_and_GUI_X_Y.txt | 8 ++--- 11 files changed, 66 insertions(+), 33 deletions(-) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 2cb7b027..1a3282ab 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -66,6 +66,7 @@ (send wx begin-refresh-sequence))] [resume-flush (lambda () (send wx end-refresh-sequence))] + [flush (lambda () (send wx flush))] [set-canvas-background (entry-point diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ed311688..b6c04bf0 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -67,6 +67,9 @@ ;; is at then end of `do-backing-flush'. (send canvas queue-backing-flush)) + (define/override (flush) + (send canvas flush)) + (define/override (request-delay) (request-flush-delay (send canvas get-flush-window))) (define/override (cancel-delay req) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 31eb3b60..5be58666 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -348,6 +348,7 @@ (lambda () (check-one-event #f #f))) (define (try-to-sync-refresh) + ;; atomically => outside of the event loop (atomically (pre-event-sync #t))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 94265bb9..d372d8fd 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -328,7 +328,10 @@ scroll-width 0))) - (define/override (direct-update?) #f) + ;; Direct update is ok for a canvas, and it + ;; allows pushing updates to the screen even + ;; if the eventspace thread is busy indefinitely + (define/override (direct-update?) #t) (define/public (get-dc) dc) @@ -377,15 +380,18 @@ (define/public (end-refresh-sequence) (send dc resume-flush)) + ;; The `flush' method should be improved to flush local + ;; to the enclosing frame, instead of flushing globally. + (define/public (flush) + (flush-display)) + (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) ;; called atomically (unless for-gl? - (gtk_widget_queue_draw client-gtk) - ;; peridodically flush to the screen: - (schedule-periodic-backing-flush))) + (gtk_widget_queue_draw client-gtk))) (define/override (reset-child-dcs) (when (dc . is-a? . dc%) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index bc770391..518ca143 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -125,6 +125,9 @@ (end-delay) (send canvas queue-backing-flush)) + (define/override (flush) + (send canvas flush)) + (define/override (request-delay) (request-flush-delay (send canvas get-flush-window))) (define/override (cancel-delay req) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 3b9316a4..2fc6525d 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -251,6 +251,11 @@ (send dc suspend-flush)) (define/public (end-refresh-sequence) (send dc resume-flush)) + + ;; The `flush' method should be improved to flush local + ;; to the enclosing frame, instead of flushing globally. + (define/public (flush) + (flush-display)) ;; Improve this method to flush locally ;; instead of globally: diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index d3b6ead0..db260240 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -99,6 +99,9 @@ (end-delay) (send canvas queue-backing-flush)) + (define/override (flush) + (send canvas flush)) + (define/override (request-delay) (request-flush-delay canvas)) (define/override (cancel-delay req) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 161333d8..be13bbe9 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -94,6 +94,7 @@ The @scheme[gl-config] argument determines properties of an OpenGL } + @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) (integer-in 1 1000000)]{ @@ -284,11 +285,6 @@ This method is called only when manual } -@defmethod[(resume-flush) void?]{ - -See @method[canvas% suspend-flush].} - - @defmethod[(scroll [h-value (or/c (real-in 0.0 1.0) false/c)] [v-value (or/c (real-in 0.0 1.0) false/c)]) void?]{ @@ -389,22 +385,6 @@ init-manual-scrollbars]. } -@defmethod[(suspend-flush) void?]{ - -Drawing to a canvas's drawing context actually renders into an -offscreen buffer. The buffer is automatically flushed to the screen by -a background thread, unless flushing has been disabled for the canvas. -The @method[canvas% suspend-flush] method suspends flushing for a -canvas until a matching @method[canvas% resume-flush] calls; calls to -@method[canvas% suspend-flush] and @method[canvas% resume-flush] can -be nested, in which case flushing is suspended until the outermost -@method[canvas% suspend-flush] is balanced by a @method[canvas% -resume-flush]. - -On some platforms, beware that suspending flushing for a canvas can -discourage refreshes for other windows in the same frame.} - - @defmethod[(swap-gl-buffers) void?]{ Calls diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index d7544a94..e802de77 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -48,6 +48,11 @@ For an @scheme[editor-canvas%] object, handling of Tab, arrow, Enter, } +@defmethod[(flush) void?]{ + +Like @racket[flush-display], but constrained if possible to the canvas.} + + @defmethod[(get-canvas-background) (or/c (is-a?/c color%) false/c)]{ Returns the color currently used to ``erase'' the canvas content before @@ -184,6 +189,12 @@ Does nothing. }} +@defmethod[(resume-flush) void?]{ + +See @method[canvas<%> suspend-flush].} + + + @defmethod[(set-canvas-background [color (is-a?/c color%)]) void?]{ @@ -209,6 +220,24 @@ Under Mac OS X, enables or disables space for a resize tab at the } + +@defmethod[(suspend-flush) void?]{ + +Drawing to a canvas's drawing context actually renders into an +offscreen buffer. The buffer is automatically flushed to the screen by +a background thread, explicitly via the @method[canvas<%> flush] method, +or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas. +The @method[canvas<%> suspend-flush] method suspends flushing for a +canvas until a matching @method[canvas<%> resume-flush] calls; calls to +@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can +be nested, in which case flushing is suspended until the outermost +@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%> +resume-flush]. + +On some platforms, beware that suspending flushing for a canvas can +discourage refreshes for other windows in the same frame.} + + @defmethod[(warp-pointer [x (integer-in 0 10000)] [y (integer-in 0 10000)]) void?]{ diff --git a/collects/scribblings/gui/global-draw-funcs.scrbl b/collects/scribblings/gui/global-draw-funcs.scrbl index 2790d63d..d8f77670 100644 --- a/collects/scribblings/gui/global-draw-funcs.scrbl +++ b/collects/scribblings/gui/global-draw-funcs.scrbl @@ -6,11 +6,13 @@ @defproc[(flush-display) void?]{ -Under X and Mac OS X, flushes pending display messages such that the - user's display reflects the actual state of the windows. Under - Windows, the procedure has no effect. +Flushes canvas offscreen drawing and other updates onto the + screen. + +Normally, drawing is automatically flushed to the screen. Use +@racket[flush-display] sparingly to force updates to the screen when +other actions depend on updating the display.} -} @defproc[(get-display-depth) exact-nonnegative-integer?]{ diff --git a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt index b881f0f4..f179447c 100644 --- a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt +++ b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt @@ -59,10 +59,10 @@ Canvases -------- Drawing to a canvas always draws into a bitmap that is kept offscreen -and periodically flushed onto the screen. The new `suspend-flush' and -`resume-flush' methods of `canvas%' provide some control over the -timing of the flushes, which in many cases avoids the need for -(additional) double buffering of canvas content. +and periodically flushed onto the screen. The new `suspend-flush', +`resume-flush', and `flush' methods of `canvas%' provide some control +over the timing of the flushes, which in many cases avoids the need +for (additional) double buffering of canvas content. OpenGL drawing in a canvas requires supplying 'gl as a style when creating the `canvas%' instance. OpenGL and normal dc<%> drawing no From aa73bfcdf10dd44c0ce6fe96429e8fb3c623995d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Nov 2010 16:36:00 -0600 Subject: [PATCH 351/462] win32: fix flush duplocate def original commit: 9f42fa0e6fe66910932736cb7018d1568f22b530 --- collects/mred/private/wx/win32/canvas.rkt | 5 ----- 1 file changed, 5 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 2fc6525d..3b9316a4 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -251,11 +251,6 @@ (send dc suspend-flush)) (define/public (end-refresh-sequence) (send dc resume-flush)) - - ;; The `flush' method should be improved to flush local - ;; to the enclosing frame, instead of flushing globally. - (define/public (flush) - (flush-display)) ;; Improve this method to flush locally ;; instead of globally: From 5c18c9a5f3028e47f7c705463ce2cb21847b5143 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 13:50:41 -0600 Subject: [PATCH 352/462] cocoa and gtk: fix combo% `on-popup' method original commit: 39596efef5a79c81475f3a2a5e78420b924a9a84 --- collects/mred/private/mrtextfield.rkt | 35 ++++++--- collects/mred/private/wx/cocoa/canvas.rkt | 11 ++- collects/mred/private/wx/gtk/canvas.rkt | 24 +++++- collects/mred/private/wx/gtk/window.rkt | 5 +- collects/mred/private/wx/win32/canvas.rkt | 4 + collects/mred/private/wxcanvas.rkt | 10 ++- collects/mred/private/wxtextfield.rkt | 6 +- .../scribblings/gui/combo-field-class.scrbl | 25 +++---- collects/tests/gracket/combo-steps.txt | 12 +++ collects/tests/gracket/item.rkt | 74 +++++++++++++++++++ doc/release-notes/racket/Draw_and_GUI_X_Y.txt | 13 +++- 11 files changed, 184 insertions(+), 35 deletions(-) create mode 100644 collects/tests/gracket/combo-steps.txt diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index c3747db1..f7d81de5 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -101,20 +101,30 @@ parent callback init-value style #f font)) + (private + [prep-popup + (lambda () + (send menu on-demand) + (let ([items (send menu get-items)] + [wx (mred->wx this)]) + (send wx clear-combo-items) + (for-each + (lambda (item) + (unless (item . is-a? . separator-menu-item%) + (send wx append-combo-item + (send item get-plain-label) + (lambda () + (send item command + (make-object wx:control-event% 'menu-popdown)))))) + items)))]) (public - [on-popup (lambda (e) - (let-values ([(w h) (get-size)] - [(cw) (send (mred->wx this) get-canvas-width)]) - (send menu set-min-width cw) - (popup-menu menu (- w cw) h)))] + [on-popup (lambda (e) (void))] [get-menu (lambda () menu)] [append (lambda (item) (check-label-string '(method combo-field% append) item) - (unless (send (mred->wx this) append-combo-item item - (lambda () (handle-selected item))) - (make-object menu-item% item menu - (lambda (i e) - (handle-selected item)))))]) + (make-object menu-item% item menu + (lambda (i e) + (handle-selected item))))]) (private [handle-selected (lambda (item) (focus) @@ -128,5 +138,10 @@ [menu (new popup-menu% [font font])]) (sequence (super-init label parent callback init-value (list* combo-flag 'single style)) + (send (mred->wx this) + set-on-popup + (lambda () + (on-popup (make-object wx:control-event% 'menu-popdown)) + (prep-popup))) (for-each (lambda (item) (append item)) choices))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7abf4dea..bf75a67a 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -601,6 +601,8 @@ (scroller-page scroller) 1)])) + (define/public (clear-combo-items) + (tellv content-cocoa removeAllItems)) (define/public (append-combo-item str) (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) #t) @@ -698,10 +700,15 @@ (get-client-size xb yb) ((send e get-x) . > . (- (unbox xb) 22)))) + (define/public (on-popup) (void)) + (define/public (starting-combo) (set! in-menu-click? #t) - (tellv content-cocoa setStringValue: #:type _NSString current-text)) - + (tellv content-cocoa setStringValue: #:type _NSString current-text) + (constrained-reply (get-eventspace) + (lambda () (on-popup)) + (void))) + (define/public (ending-combo) (set! in-menu-click? #f) (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index d372d8fd..eb19b784 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -40,6 +40,7 @@ (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) (define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) @@ -190,7 +191,8 @@ set-auto-size adjust-client-delta infer-client-delta is-auto-scroll? get-virtual-width get-virtual-height - refresh-for-autoscroll) + refresh-for-autoscroll + get-eventspace) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -341,6 +343,12 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) + (define/override (internal-pre-on-event gtk e) + (when (and (ptr-equal? gtk combo-button-gtk) + (send e button-down?)) + (on-popup)) + #f) + (define/override (get-client-delta) (values margin margin)) @@ -535,8 +543,20 @@ (when is-combo? (connect-changed client-gtk)) + (define combo-count 0) + (define/public (clear-combo-items) + (atomically + (for ([n (in-range combo-count)]) + (gtk_combo_box_remove_text gtk 0)) + (set! combo-count 0))) (define/public (append-combo-item str) - (gtk_combo_box_append_text gtk str)) + (atomically + (set! combo-count (add1 combo-count)) + (gtk_combo_box_append_text gtk str))) + + (when is-combo? (append-combo-item "...")) + + (define/public (on-popup) (void)) (define/public (combo-maybe-clicked) (let ([i (gtk_combo_box_get_active gtk)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b55c04c1..e4cc352e 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -346,7 +346,8 @@ (send wx dispatch-on-event m #f))) #t) (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) + (lambda () (or (send wx dispatch-on-event m #t) + (send wx internal-pre-on-event gtk m))) #t)))))))) ;; ---------------------------------------- @@ -590,6 +591,8 @@ [just-pre? #f] [else (when enabled? (on-event e)) #t])) + (define/public (internal-pre-on-event gtk e) #f) + (define/public (call-pre-on-event w e) (or (send parent call-pre-on-event w e) (pre-on-event w e))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 3b9316a4..9191ba93 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -453,6 +453,10 @@ (define/public (set-combo-text s) (void)) (define/public (append-combo-item s) (SendMessageW/str combo-hwnd CB_ADDSTRING 0 s)) + (define/public (clear-combo-items) + (void)) + + (define/public (on-popup) (void)) (define/override (is-command? cmd) (= cmd CBN_SELENDOK)) diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 94da953f..8d8591b3 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/collects/mred/private/wxcanvas.rkt @@ -23,14 +23,16 @@ [do-on-scroll (lambda (e) (super on-scroll e))] [do-on-paint (lambda () (super on-paint))]) (private-field - [tabable? default-tabable?]) + [tabable? default-tabable?] + [on-popup-callback void]) (public [get-tab-focus (lambda () tabable?)] [set-tab-focus (lambda (v) (set! tabable? v))] [on-tab-in (lambda () (let ([mred (wx->mred this)]) (when mred - (send mred on-tab-in))))]) + (send mred on-tab-in))))] + [set-on-popup (lambda (proc) (set! on-popup-callback proc))]) (override [gets-focus? (lambda () tabable?)] [handles-key-code @@ -68,7 +70,9 @@ (let ([mred (get-mred)]) (if mred (as-exit (lambda () (clear-and-on-paint mred))) - (as-exit (lambda () (clear-margins) (super on-paint)))))))]) + (as-exit (lambda () (clear-margins) (super on-paint)))))))] + ;; for 'combo canvases: + [on-popup (lambda () (on-popup-callback))]) (sequence (apply super-init mred proxy args)))) (define wx-canvas% diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index d7a618d7..e87ae2c8 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -167,7 +167,9 @@ (make-object wx-message% #f proxy p label -1 -1 null font))] [c (make-object (class wx-text-editor-canvas% (define/override (on-combo-select i) - ((list-ref callbacks (- (length callbacks) i 1)))) + (let ([len (length callbacks)]) + (when (< -1 i len) + ((list-ref callbacks (- len i 1)))))) (super-new)) #f proxy this p (append @@ -182,6 +184,8 @@ '(hide-vscroll hide-hscroll))))] [callbacks null]) (public + [set-on-popup (lambda (proc) (send c set-on-popup proc))] + [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))] [append-combo-item (lambda (s cb) (and (send c append-combo-item s) (set! callbacks (cons cb callbacks)) diff --git a/collects/scribblings/gui/combo-field-class.scrbl b/collects/scribblings/gui/combo-field-class.scrbl index c2b0a74f..14b54d5f 100644 --- a/collects/scribblings/gui/combo-field-class.scrbl +++ b/collects/scribblings/gui/combo-field-class.scrbl @@ -5,8 +5,8 @@ A @scheme[combo-field%] object is a @scheme[text-field%] object that also resembles a @scheme[choice%] object, because it - has a small popup button to the right of the text field. By default, - clicking the button pops up a menu, and selecting a menu item copies + has a small popup button to the right of the text field. Clicking + the button pops up a menu, and selecting a menu item typically copies the item into the text field. @@ -40,9 +40,8 @@ The @scheme[choices] list specifies the initial list of items for the combo's popup menu. The @method[combo-field% append] method adds a new item to the menu with a callback to install the appended item into the combo's text field. The -@method[combo-field% get-menu] method returns the combo's menu to allow arbitrary other operations. - This menu might not be used at all if -@method[combo-field% on-popup] is overridden. +@method[combo-field% get-menu] method returns a menu that can be changed to + adjust the content and actions of the combo's menu. The @scheme[callback] procedure is called when the user changes the text in the combo or presses the Enter key (and Enter is not handled by @@ -75,11 +74,10 @@ Adds a new item to the combo's popup menu. The given label is used for @defmethod[(get-menu) (is-a?/c popup-menu%)]{ -Returns the @scheme[popup-menu%] that is used by the default -@method[combo-field% on-popup] method. This menu is initialized with the @scheme[labels] argument when - the @scheme[combo-field%] is created, and the -@method[combo-field% append] method adds a new item to the menu. - +Returns a @scheme[popup-menu%] that is effectively copied into the + combo's popup menu when the combo is clicked. Only the labels can + callbacks of the menu's items are used; the enable state, submenus, + or separators are ignored. } @@ -88,14 +86,13 @@ Returns the @scheme[popup-menu%] that is used by the default @methspec{ -Called when the user clicks the combo's popup button. +Called when the user clicks the combo's popup button. Override this method +to adjust the content of the combo menu on demand. } @methimpl{ -Gets a menu from -@method[combo-field% get-menu], sets its minimum width to match the combo control's width, and - then pops up the menu. +Does nothing. }} diff --git a/collects/tests/gracket/combo-steps.txt b/collects/tests/gracket/combo-steps.txt new file mode 100644 index 00000000..80a569cd --- /dev/null +++ b/collects/tests/gracket/combo-steps.txt @@ -0,0 +1,12 @@ +Set Up, Callbacks, Appending +---------------------------- + +The choice/list should contain "Apple" and "Banana" for + starters. + +Watch for "Popup!" printed to stdout when you click the choice item. + +When you use "Reset", the content should change to "Alpha", "Beta", + and "Gamma", and selecting them should install the word plus + "for Reset" into the text field. + diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 4e32dd54..493bfedc 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1565,6 +1565,79 @@ (instructions p "choice-list-steps.txt") (send f show #t)) +(define (combo-frame empty?) + (define f (make-frame frame% "Combo Test")) + (define p f) + (define actual-content '("Apple" "Banana")) + (define (callback c e) (void)) + (define c (make-object (class combo-field% + (define/override (on-popup e) + (printf "Popup!\n")) + (super-new)) + "Tester" actual-content p callback)) + (define counter 0) + (define append-with-user-data? #f) + (define ab (make-object button% + "Append" p + (lambda (b e) + (set! counter (add1 counter)) + (let ([naya (format "~aExtra ~a" + (if (= counter 10) + (string-append + "This is a Really Long Named Item That Would Have Used the Short Name, Yes " + "This is a Really Long Named Item That Would Have Used the Short Name ") + "") + counter)] + [naya-data (box 0)]) + (set! actual-content (append actual-content (list naya))) + (send c append naya))))) + (define asb (make-object button% + "Append Separator" p + (lambda (b e) + (set! counter (add1 counter)) + (new separator-menu-item% [parent (send c get-menu)])))) + (define cdp (make-object horizontal-panel% p)) + (define (clear) + (for ([i (send (send c get-menu) get-items)]) + (send i delete))) + (define rb (make-object button% "Clear" cdp + (lambda (b e) (clear)))) + (define (gone l n) + (if (zero? n) + (cdr l) + (cons (car l) (gone (cdr l) (sub1 n))))) + (define (delete p) + (send (list-ref (send (send c get-menu) get-items) p) delete) + (when (<= 0 p (sub1 (length actual-content))) + (set! actual-content (gone actual-content p)))) + (define db (make-object button% + "Delete First" cdp + (lambda (b e) + (unless (null? actual-content) + (delete 0))))) + (define dbe (make-object button% + "Delete Last" cdp + (lambda (b e) + (unless (null? actual-content) + (delete (sub1 (length actual-content))))))) + (define setb (make-object button% + "Reset" cdp + (lambda (b e) + (clear) + (let ([m (send c get-menu)]) + (for ([i '("Alpha" "Beta" "Gamma")]) + (new menu-item% [parent m] [label i] + [callback (lambda (itm e) + (send c set-value + (format "~a from Reset" i)))])))))) + (define tb (make-object button% + "Check" p + (lambda (b e) + (void)))) + (send c stretchable-width #t) + (instructions p "combo-steps.txt") + (send f show #t)) + (define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) @@ -2163,6 +2236,7 @@ (send cp stretchable-width #f) (make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f))) (make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t))) +(make-object button% "Make Combo Frame" cp (lambda (b e) (combo-frame #f))) (define lp (make-object horizontal-pane% ap)) (send lp stretchable-width #f) (make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f))) diff --git a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt index f179447c..3e20f6fe 100644 --- a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt +++ b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt @@ -93,8 +93,8 @@ backward-compatibile. Methods like `get-translation', `set-translation', `scale', etc. help hide the reundancy. -Others Drawing-Context Changes ------------------------------- +Other Drawing-Context Changes +----------------------------- The alpha value of a `dc<%>' (as set by `set-alpha') is used for all drawing operations, including drawing a bitmap. @@ -122,6 +122,15 @@ background for the selected region, and it should draw the foreground in the color specified by `get-highlight-text-color', if any. +Other GUI Changes +----------------- + +The `on-popup' method of `combo-field%' can be used to adjust the +content of the combo-box popup menu, but the default implementation no +longer triggers the popup menu; instead, the popup behavior is built +into the control. + + Removed Functions ----------------- From ec4cd58f1dfc9910d2b9e4430cece4cfc7bd3c16 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 14:05:31 -0600 Subject: [PATCH 353/462] win32: fix combo% on-popup original commit: f935266257b22ccb40fa6cde56711b096ae286aa --- collects/mred/private/wx/win32/canvas.rkt | 13 +++++++++---- collects/mred/private/wx/win32/choice.rkt | 4 ---- collects/mred/private/wx/win32/const.rkt | 7 ++++++- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 9191ba93..e871aeb2 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -454,16 +454,21 @@ (define/public (append-combo-item s) (SendMessageW/str combo-hwnd CB_ADDSTRING 0 s)) (define/public (clear-combo-items) - (void)) + (SendMessageW combo-hwnd CB_RESETCONTENT 0 0)) (define/public (on-popup) (void)) (define/override (is-command? cmd) - (= cmd CBN_SELENDOK)) + (or (= cmd CBN_SELENDOK) + (= cmd CBN_DROPDOWN))) (define/public (do-command cmd control-hwnd) - (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) - (queue-window-event this (lambda () (on-combo-select i))))) + (cond + [(= cmd CBN_SELENDOK) + (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) + (queue-window-event this (lambda () (on-combo-select i))))] + [(= cmd CBN_DROPDOWN) + (constrained-reply (get-eventspace) (lambda () (on-popup)) (void))])) (define/override (is-hwnd? a-hwnd) (or (ptr-equal? panel-hwnd a-hwnd) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 4a045e7a..b189c0a9 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -15,10 +15,6 @@ (provide (protect-out choice%)) -(define CBN_DROPDOWN 7) -(define CBN_CLOSEUP 8) -(define CBN_SELENDCANCEL 10) - (define choice% (class item% (init parent cb label diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index ecfcc941..6f8b4cb8 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -616,6 +616,11 @@ (define CB_INSERTSTRING #x014A) (define CB_SETCURSEL #x014E) (define CB_GETCURSEL #x0147) -(define CBN_SELENDOK 9) (define CB_ADDSTRING #x0143) (define CB_RESETCONTENT #x014B) + +(define CBN_SELENDOK 9) +(define CBN_DROPDOWN 7) +(define CBN_CLOSEUP 8) +(define CBN_SELENDCANCEL 10) + From a4d31e5e8656c44e04e7a018a1d2fb40dcfcaca2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 14:26:16 -0600 Subject: [PATCH 354/462] v5.0.99.1 original commit: 263000a7b863b2d8e238823634554a5af998a1cd --- .../racket/{Draw_and_GUI_X_Y.txt => Draw_and_GUI_5_1.txt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename doc/release-notes/racket/{Draw_and_GUI_X_Y.txt => Draw_and_GUI_5_1.txt} (100%) diff --git a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt similarity index 100% rename from doc/release-notes/racket/Draw_and_GUI_X_Y.txt rename to doc/release-notes/racket/Draw_and_GUI_5_1.txt From e4ffaabd35faf68bea9a07ced7faebfcb662cd94 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 15:14:23 -0600 Subject: [PATCH 355/462] fix merge mistake original commit: 1db27b474f32f0c136f91b509b02b4a48da0f2dd --- collects/mrlib/image-core.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index e93bf5d8..0190fbf9 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -719,8 +719,8 @@ has been moved out). (curve-segment-e-pull shape) (scale-color (curve-segment-color shape) x-scale y-scale))]) (render-poly/line-segment/curve-segment this-one dc dx dy))] - [(or (bitmap? shape) (np-atomic-shape? shape)) - (let* ([shape (if (bitmap? shape) + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let* ([shape (if (ibitmap? shape) (make-flip #f shape) shape)] [this-one (scale-np-atomic x-scale y-scale shape)]) From bca0c001529c78b4e797523564beea02e7fed970 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 15:53:16 -0600 Subject: [PATCH 356/462] fix release-note link and version original commit: 601b411671bcb799ce22c116e8b2af5061e0c9a4 --- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 3e20f6fe..26a02390 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -1,7 +1,7 @@ GRacket, Racket, Drawing, and GUIs ---------------------------------- -Version X.Y includes two major changes to the Racket drawing and GUI +Version 5.1 includes two major changes to the Racket drawing and GUI API: * The drawing portion of the GUI toolbox is now available as a From 63450356244583ba7a58c31cd7541fe64b96734b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 20:26:24 -0600 Subject: [PATCH 357/462] avoid xor for pasteboard rubberband hiliting original commit: 59bf78b6c8b40a1e2a57b8c495a14fe37c79fbe3 --- collects/mred/private/wxme/pasteboard.rkt | 64 ++++++++++++++--------- 1 file changed, 38 insertions(+), 26 deletions(-) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index e1a7d208..4bb1e8d7 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -34,8 +34,9 @@ (define black-brush (send the-brush-list find-or-create-brush "black" 'xor)) (define white-brush (send the-brush-list find-or-create-brush "white" 'solid)) (define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) -(define rb-brush (send the-brush-list find-or-create-brush "black" 'transparent)) -(define rb-pen (send the-pen-list find-or-create-pen "black" 1 'xor-dot)) +(define invisi-brush (send the-brush-list find-or-create-brush "black" 'transparent)) +(define rb-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'xor-dot)) +(define rb-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define arrow (make-object cursor% 'arrow)) @@ -122,6 +123,11 @@ (define dragging? #f) (define rubberband? #f) + (define rb-x 0.0) + (define rb-y 0.0) + (define rb-w 0.0) + (define rb-h 0.0) + (define need-resize? #f) (define resizing #f) ; a snip @@ -167,7 +173,7 @@ ;; ---------------------------------------- - (define/private (rubber-band x y w h) + (define/private (rubber-band-update x y w h) (when (and s-admin (not (zero? w)) (not (zero? h))) @@ -192,22 +198,11 @@ [b (min b (+ vy vh))]) (unless (or (x . >= . r) (y . >= . b)) - (let-boxes ([dc #f] - [dx 0.0] - [dy 0.0]) - (set-box! dc (send s-admin get-dc dx dy)) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-pen rb-pen) - (send dc set-brush rb-brush) - - (send dc draw-rectangle - (- x dx) (- y dy) - (- r x) - (- b y)) - - (send dc set-pen old-pen) - (send dc set-brush old-brush)))))))))) + (set! rb-x x) + (set! rb-y y) + (set! rb-w (- r x)) + (set! rb-h (- b y)) + (update rb-x rb-y rb-w rb-h)))))))) (def/override (adjust-cursor [mouse-event% event]) (if (not s-admin) @@ -317,7 +312,7 @@ (when rubberband? (set! rubberband? #f) - (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) (add-selected start-x start-y (- last-x start-x) (- last-y start-y)) (update-all))) @@ -377,10 +372,12 @@ (when (send event dragging?) (cond [rubberband? + (begin-edit-sequence) ;; erase old - (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) ;; draw new: - (rubber-band start-x start-y (- x start-x) (- y start-y))] + (rubber-band-update start-x start-y (- x start-x) (- y start-y)) + (end-edit-sequence)] [resizing (do-event-resize x y)] [else @@ -916,6 +913,8 @@ (on-resize snip w h) (set! write-locked (sub1 write-locked)) + (update-location loc) + (let ([rv? (and (send snip resize w h) (begin @@ -935,6 +934,8 @@ (after-resize snip w h rv?) + (update-location loc) + (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) @@ -1275,6 +1276,17 @@ show-caret 'no-caret)) + (when rubberband? + (let ([a (send dc get-alpha)]) + (send dc set-alpha (* a 0.5)) + (send dc set-brush rb-brush) + (send dc set-pen invisi-pen) + (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h) + (send dc set-pen rb-pen) + (send dc set-alpha a) + (send dc set-brush invisi-brush) + (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h))) + (set! flow-locked? #f) (set! write-locked (sub1 write-locked)))))) @@ -1440,14 +1452,14 @@ (set! update-top (min y update-top)) (set! update-left (min x update-left)) (set! update-bottom (max b update-bottom)) - (when (symbol? b) - (if (eq? b 'display-end) + (when (symbol? h) + (if (eq? h 'display-end) (set! update-bottom-end 'display-end) (unless (eq? update-bottom-end 'display-end) (set! update-bottom-end 'end)))) (set! update-right (max r update-right)) - (when (symbol? r) - (if (eq? r 'display-end) + (when (symbol? w) + (if (eq? w 'display-end) (set! update-right-end 'display-end) (unless (eq? update-right-end 'display-end) (set! update-right-end 'end)))))) From 86008d2f9a091e4591da582390881035ebb9b0af Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Nov 2010 21:53:36 -0600 Subject: [PATCH 358/462] first cut at splitting draw and gui docs original commit: 694745e9985a65bbbfdf0c9853e472ee18a2476d --- collects/mred/mred-sig.rkt | 3 - collects/mred/mred.rkt | 38 +----------- collects/mred/private/fontdialog.rkt | 4 +- collects/mred/private/gdi.rkt | 59 +------------------ collects/scribblings/gui/blurbs.rkt | 31 ++++------ collects/scribblings/gui/font-funcs.scrbl | 22 ------- collects/scribblings/gui/gui.scrbl | 23 ++------ collects/scribblings/gui/guide.scrbl | 18 +----- collects/scribblings/gui/prefs.scrbl | 38 ------------ .../scribblings/gui/printer-dc-class.scrbl | 11 ++-- collects/scribblings/gui/reference.scrbl | 2 - collects/scribblings/gui/win-classes.scrbl | 1 + collects/scribblings/gui/win-funcs.scrbl | 2 + doc/release-notes/racket/Draw_and_GUI_5_1.txt | 4 ++ 14 files changed, 35 insertions(+), 221 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 989e0ace..1f8aa217 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -1,4 +1,3 @@ - #lang scheme/signature add-color<%> @@ -38,8 +37,6 @@ control<%> current-eventspace current-eventspace-has-menu-root? current-eventspace-has-standard-menus? -current-ps-afm-file-paths -current-ps-cmap-file-paths current-ps-setup current-text-keymap-initializer cursor% diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 5fdbb4e1..5c10a451 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -4,6 +4,7 @@ namespace-anchor->empty-namespace make-base-empty-namespace) scheme/class + racket/draw mzlib/etc (prefix wx: "private/kernel.ss") (prefix wx: "private/wxme/style.ss") @@ -101,26 +102,15 @@ add-pasteboard-keymap-functions begin-busy-cursor bell - bitmap% - make-bitmap - read-bitmap - make-monochrome-bitmap - brush% - brush-list% editor-data% editor-data-class% editor-data-class-list<%> check-for-break clipboard<%> clipboard-client% - color% - color-database<%> control-event% current-eventspace - current-ps-setup cursor% - dc<%> - dc-path% get-display-depth end-busy-cursor event% @@ -128,10 +118,7 @@ eventspace? find-graphical-system-path flush-display - font% - font-list% - font-name-directory<%> - get-highlight-background-color + get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list get-the-snip-class-list @@ -152,14 +139,9 @@ editor-wordbreak-map% mouse-event% mult-color<%> - pen% - pen-list% - point% - ps-setup% read-editor-global-footer read-editor-global-header read-editor-version - region% scroll-event% snip% snip-admin% @@ -181,14 +163,7 @@ yield eventspace-shutdown? get-panel-background - gl-context<%> - gl-config% - the-color-database - the-font-name-directory - the-font-list - the-pen-list - the-brush-list the-style-list the-editor-wordbreak-map make-screen-bitmap @@ -197,9 +172,7 @@ (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) - ;; Obsolete - (define current-ps-afm-file-paths (make-parameter null)) - (define current-ps-cmap-file-paths (make-parameter null)) + (provide (all-from racket/draw)) (provide button% canvas% @@ -277,13 +250,10 @@ get-top-level-edit-target-window register-collecting-blit unregister-collecting-blit - bitmap-dc% - post-script-dc% printer-dc% current-text-keymap-initializer sleep/yield get-window-text-extent - get-family-builtin-face send-message-to-window the-clipboard the-x-selection-clipboard @@ -309,8 +279,6 @@ make-gui-namespace make-gui-empty-namespace file-creator-and-type - current-ps-afm-file-paths - current-ps-cmap-file-paths hide-cursor-until-moved system-position-ok-before-cancel? label-string? diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 035f1118..c8c37957 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -39,7 +39,7 @@ (let ([s (send (send edit get-style-list) find-named-style "Standard")]) (send s set-delta (font->delta f))))))] [p (make-object horizontal-pane% f)] - [face (make-object list-box% #f (get-face-list) p refresh-sample)] + [face (make-object list-box% #f (wx:get-face-list) p refresh-sample)] [p2 (make-object vertical-pane% p)] [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])] [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])]) @@ -98,7 +98,7 @@ (lambda (font) (let* ([facen (if font (send font get-face) - (get-family-builtin-face 'default))] + (wx:get-family-builtin-face 'default))] [f (and facen (send face find-string facen))]) (and f (>= f 0) (send face set-selection f))) (when font diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 7ef08bcc..89a847bb 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -13,17 +13,13 @@ (provide register-collecting-blit unregister-collecting-blit - bitmap-dc% - post-script-dc% printer-dc% get-window-text-extent - get-family-builtin-face normal-control-font small-control-font tiny-control-font view-control-font - menu-control-font - get-face-list) + menu-control-font) (define register-collecting-blit (case-lambda @@ -50,14 +46,6 @@ (check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas) (wx:unregister-collecting-blit (mred->wx canvas)))) - (define bitmap-dc% - (class100 wx:bitmap-dc% ([bitmap #f]) - (inherit set-bitmap) - (sequence - (super-init) - (when bitmap - (set-bitmap bitmap))))) - (define-syntax check-page-active (syntax-rules () [(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)])) @@ -167,20 +155,6 @@ (super-new))) - (define post-script-dc% - (class (doc+page-check-mixin wx:post-script-dc% 'post-script-dc%) - (init [interactive #t][parent #f][use-paper-bbox #f][as-eps #t]) - - (check-top-level-parent/false '(constructor post-script-dc) parent) - - (define is-eps? (and as-eps #t)) - (define/override (multiple-pages-ok?) (not is-eps?)) - - (as-entry - (lambda () - (let ([p (and parent (mred->wx parent))]) - (as-exit (lambda () (super-make-object interactive p use-paper-bbox as-eps)))))))) - (define printer-dc% (class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f]) (sequence @@ -199,37 +173,6 @@ (check-instance 'get-window-text-extent wx:font% 'font% #f font) (let-values ([(w h d a) (get-window-text-extent* string font combine?)]) (values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))])) - - (define ugly? - (lambda (a) - (and (positive? (string-length a)) - (not (or (char-alphabetic? (string-ref a 0)) - (char-numeric? (string-ref a 0)) - (char=? #\- (string-ref a 0))))))) - - (define compare-face-names - (lambda (a b) - (let ([a-sp? (char=? #\space (string-ref a 0))] - [b-sp? (char=? #\space (string-ref b 0))] - [a-ugly? (ugly? a)] - [b-ugly? (ugly? b)]) - (cond [(eq? a-sp? b-sp?) - (cond - [(eq? a-ugly? b-ugly?) - (string-locale-ci].}) - (define MismatchExn @elem{an @scheme[exn:fail:contract] exception is raised}) - (define AFM @elem{Adobe Font Metrics}) (define (MonitorMethod what by-what method whatsit) @@ -244,18 +250,6 @@ information@|details|, even if the editor currently has delayed refreshing (see (hspace 1) (bytes->string/latin-1 name)))) - (define (res-sym s) - (string->symbol (string-append "GRacket:" s))) - - (define (Resource s) - @elem{@to-element[`(quote ,(res-sym s))] - preference}) - (define (ResourceFirst s) ; fixme -- add index - (let ([r (Resource s)]) - (index* (list (format "~a preference" (res-sym s))) - (list r) - r))) - (define (edsnipsize a b c) @elem{An @scheme[editor-snip%] normally stretches to wrap around the size of the editor it contains. This method @|a| of the snip @@ -269,11 +263,6 @@ information@|details|, even if the editor currently has delayed refreshing (see "smaller" @elem{the editor is @|b|-aligned in the snip})) - (define (boxisfill which what) - @elem{The @|which| box is filled with @|what|.}) - (define (boxisfillnull which what) - @elem{The @|which| box is filled with @|what|, unless @|which| is @scheme[#f].}) - (define (slant . s) (make-element "slant" (decode-content s))) diff --git a/collects/scribblings/gui/font-funcs.scrbl b/collects/scribblings/gui/font-funcs.scrbl index 74923e89..3eef2d2d 100644 --- a/collects/scribblings/gui/font-funcs.scrbl +++ b/collects/scribblings/gui/font-funcs.scrbl @@ -3,28 +3,6 @@ @title{Fonts} - -@defproc[(get-face-list [family (one-of/c 'mono 'all) 'all]) - (listof string?)]{ - -Returns a list of font face names available on the current system. If - @scheme['mono] is provided as the argument, then only faces that are - known to correspond to monospace fonts are included in the list. - -} - -@defproc[(get-family-builtin-face [family (one-of/c 'default 'decorative 'roman 'script - 'swiss 'modern 'symbol 'system)]) - string?]{ - -Returns the built-in default face mapping for a particular font - family. The built-in default can be overridden via preferences, as - described in @secref["fontresources"]. - -See @scheme[font%] for information about @scheme[family]. - -} - @defthing[menu-control-font (is-a?/c font%)]{ This font is the default for @scheme[popup-menu%] objects. diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 3fced25b..31cdac7a 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "common.ss") -@title{@bold{GUI}: Racket Graphics Toolkit} +@title{@bold{GUI}: Racket Graphical Interface Toolkit} @author["Matthew Flatt" "Robert Bruce Findler" "John Clements"] @@ -9,12 +9,13 @@ @defmodule*/no-declare[(racket/gui/base)]{The @racketmodname[racket/gui/base] library provides all of the class, -interface, and procedure bindings defined in this manual.} +interface, and procedure bindings defined in this manual, in addition +to the bindings of @racketmodname[racket/draw].} @defmodulelang*/no-declare[(racket/gui)]{The @racketmodname[racket/gui] language combines all bindings of the @racketmodname[racket] language and the -@racketmodname[racket/gui/base] modules.} +@racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} @table-of-contents[] @@ -23,23 +24,9 @@ interface, and procedure bindings defined in this manual.} @include-section["guide.scrbl"] @include-section["reference.scrbl"] -@include-section["config.scrbl"] +@include-section["prefs.scrbl"] @include-section["dynamic.scrbl"] - -@;------------------------------------------------------------------------ - -@(bibliography - - (bib-entry #:key "Adobe99" - #:author "Adobe Systems Incorporated" - #:title "PostScript Language Reference, third edition" - #:is-book? #t - #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" - #:date "1999") - - ) - @;------------------------------------------------------------------------ @index-section[] diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index 451958a3..3b4058e5 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -4,7 +4,7 @@ @title[#:style '(toc reveal)]{Overview} For documentation purposes, the graphics toolbox is organized into - three parts: + two parts: @itemize[ @@ -13,11 +13,6 @@ For documentation purposes, the graphics toolbox is organized into text fields, and events. The windowing toolbox is described in @secref["windowing-overview"].} - @item{The @deftech{drawing toolbox}, for drawing pictures or - implementing dynamic GUI programs (such as a video game) using - drawing canvases, pens, and brushes. The drawing toolbox is - described in @secref["drawing-overview"].} - @item{The @deftech{editor toolbox}, for developing traditional text editors, editors that mix text and graphics, or free-form layout editors (such as a word processor, HTML editor, or icon-based file @@ -26,11 +21,8 @@ For documentation purposes, the graphics toolbox is organized into ] -These three parts roughly represent layers of increasing - sophistication. Simple GUI programs access only the windowing toolbox - directly, more complex programs use both the windowing and drawing - toolboxes, and large-scale applications rely on all three - toolboxes. +Simple GUI programs access only the windowing toolbox directly, while + large-scale applications tend to use the editor toolbox as well. @local-table-of-contents[] @@ -40,8 +32,4 @@ These three parts roughly represent layers of increasing @;------------------------------------------------------------------------ -@include-section["draw-overview.scrbl"] - -@;------------------------------------------------------------------------ - @include-section["editor-overview.scrbl"] diff --git a/collects/scribblings/gui/prefs.scrbl b/collects/scribblings/gui/prefs.scrbl index 0bc67865..ae694426 100644 --- a/collects/scribblings/gui/prefs.scrbl +++ b/collects/scribblings/gui/prefs.scrbl @@ -20,11 +20,6 @@ The following are the (case-sensitive) preference names used by GRacket: the basic style in a style list, and thus the default font size for an editor.} - @item{@ResourceFirst{controlFontSize} --- sets the font size for - control and menu labels (Windows, X); the font is the @scheme['system] - font, which can be configured as described in - @secref["fontresources"].} - @item{@ResourceFirst{defaultMenuPrefix} --- sets the prefix used by default for menu item shortcuts under X, one of @scheme['ctl], @scheme['meta], or @scheme['alt]. The default is @@ -32,25 +27,10 @@ The following are the (case-sensitive) preference names used by GRacket: @scheme['alt], underlined mnemonics (introduced by @litchar{&} in menu labels) are suppressed.} - @item{@ResourceFirst{altUpSelectsMenu} --- a true value makes - pressing and releasing the Alt key select the first menu in the menu - bar under X.} - @item{@ResourceFirst{emacsUndo} --- a true value makes undo in editors work as in Emacs (i.e., undo operations are themselves kept in the undo stack).} - @item{@ResourceFirst{hiliteColor} --- a string to sets the color for - highlighting text, menus, and other GUI elements under X; the - preference string should contain six hexadecimal digits, two for each - component of the color. For example, set @Resource{hiliteColor} to - @scheme["0000A0"] and set @Resource{hiliteMenuBorder} to @scheme[#t] - for a Bluecurve-like look.} - - @item{@ResourceFirst{hiliteMenuBorder} --- a true value causes a menu - selection to be highlighted with a border (in addition to a color) under - X.} - @item{@ResourceFirst{wheelStep} --- sets the default mouse-wheel step size of @scheme[editor-canvas%] objects.} @@ -61,26 +41,8 @@ The following are the (case-sensitive) preference names used by GRacket: @item{@ResourceFirst{playcmd} --- used to format a sound-playing command; see @scheme[play-sound] for details.} - @item{@ResourceFirst{forceFocus} --- a true value enables extra - effort in GRacket to move the focus to a top-level window that is shown - or raised.} - @item{@ResourceFirst{doubleClickTime} --- overrides the platform-specific default interval (in milliseconds) for double-click events.} - @item{@ResourceFirst{gamma} --- sets the gamma value used in - gamma-correcting PNG files.} - - @item{@ResourceFirst{selectionAsClipboard} --- under X, a true value - causes @scheme[the-clipboard] to be an alias to - @scheme[the-x-selection-clipboard], which means that cut and paste - operations use the X selection instead of the X clipboard. See also - @scheme[clipboard<%>].} - - ] - -In addition, preference names built from font face names can provide - or override default entries for the @scheme[font-name-directory<%>]; - see @secref["fontresources"] for information. diff --git a/collects/scribblings/gui/printer-dc-class.scrbl b/collects/scribblings/gui/printer-dc-class.scrbl index e6078bfd..f75220bd 100644 --- a/collects/scribblings/gui/printer-dc-class.scrbl +++ b/collects/scribblings/gui/printer-dc-class.scrbl @@ -3,13 +3,10 @@ @defclass/title[printer-dc% object% (dc<%>)]{ -A @scheme[printer-dc%] object is a Windows or Mac OS X printer - device context. The class cannot be instantiated under X (an - @scheme[exn:misc:unsupported] exception is raised). - -Under Mac OS X, a newly created @scheme[printer-dc%] object obtains - orientation (portrait versus landscape) and scaling information from - the current @scheme[ps-setup%] object, as determined by the +A @scheme[printer-dc%] object is a printer device context. A newly + created @scheme[printer-dc%] object obtains orientation (portrait + versus landscape) and scaling information from the current + @scheme[ps-setup%] object, as determined by the @scheme[current-ps-setup] parameter. This information can be configured by the user through a dialog shown by @scheme[get-page-setup-from-user]. diff --git a/collects/scribblings/gui/reference.scrbl b/collects/scribblings/gui/reference.scrbl index a6cf354a..707a646f 100644 --- a/collects/scribblings/gui/reference.scrbl +++ b/collects/scribblings/gui/reference.scrbl @@ -7,8 +7,6 @@ @include-section["win-classes.scrbl"] @include-section["win-funcs.scrbl"] -@include-section["draw-classes.scrbl"] -@include-section["draw-funcs.scrbl"] @include-section["editor-classes.scrbl"] @include-section["editor-funcs.scrbl"] @include-section["wxme.scrbl"] diff --git a/collects/scribblings/gui/win-classes.scrbl b/collects/scribblings/gui/win-classes.scrbl index ee89b352..afa5b9ed 100644 --- a/collects/scribblings/gui/win-classes.scrbl +++ b/collects/scribblings/gui/win-classes.scrbl @@ -57,6 +57,7 @@ Alphabetical: @include-section["pane-class.scrbl"] @include-section["panel-class.scrbl"] @include-section["popup-menu-class.scrbl"] +@include-section["printer-dc-class.scrbl"] @include-section["radio-box-class.scrbl"] @include-section["selectable-menu-item-intf.scrbl"] @include-section["separator-menu-item-class.scrbl"] diff --git a/collects/scribblings/gui/win-funcs.scrbl b/collects/scribblings/gui/win-funcs.scrbl index 248d79bb..70bb4e72 100644 --- a/collects/scribblings/gui/win-funcs.scrbl +++ b/collects/scribblings/gui/win-funcs.scrbl @@ -8,4 +8,6 @@ @include-section["dialog-funcs.scrbl"] @include-section["eventspace-funcs.scrbl"] @include-section["system-menu-funcs.scrbl"] +@include-section["global-draw-funcs.scrbl"] +@include-section["font-funcs.scrbl"] @include-section["miscwin-funcs.scrbl"] diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 26a02390..ddc76d85 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -137,3 +137,7 @@ Removed Functions The `write-resource, `get-reource', and `send-event' functions have been removed from `racket/gui/base'. If there is any demand for the removed functionality, it will be implemented in a new library. + +The `current-ps-afm-file-paths' and `current-ps-cmap-file-paths' +functions have been removed, because they no longer apply. PostScript +font information is obtained through Pango. From e10794548279b624a42e544c734c344b2b90ad2e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 6 Nov 2010 21:22:46 -0600 Subject: [PATCH 359/462] cocoa: fix a double vs. float mismatch in getting scroll positions original commit: 53febbeb6c37cb671c6a614b699d8bad649bde3a --- collects/mred/private/wx/cocoa/canvas.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index bf75a67a..e791fc55 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -561,7 +561,7 @@ 0.0)))] [(scroller) (if scroller - (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) + (->long (round (* (tell #:type _float (scroller-cocoa scroller) floatValue) (scroller-range scroller)))) 0)])) From 0700c8c5dd5a504585a91641f4393b63909f9c58 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Nov 2010 07:08:29 -0700 Subject: [PATCH 360/462] fix `find-graphical-system-path' original commit: e402d68efc6c199795fceee0d2f02c2ea3619056 --- collects/mred/mred.rkt | 16 ++- collects/mred/private/wx/cocoa/procs.rkt | 3 +- collects/mred/private/wx/gtk/procs.rkt | 9 +- collects/mred/private/wx/gtk/queue.rkt | 103 ++++++++++--------- collects/mred/private/wx/win32/procs.rkt | 6 +- collects/scribblings/gui/miscwin-funcs.scrbl | 6 +- 6 files changed, 83 insertions(+), 60 deletions(-) diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 5c10a451..3c9e5ed1 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -116,7 +116,6 @@ event% event-dispatch-handler eventspace? - find-graphical-system-path flush-display get-highlight-background-color get-highlight-text-color @@ -172,6 +171,18 @@ (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) + (define (find-graphical-system-path what) + (unless (memq what '(init-file x-display)) + (raise-type-error 'find-graphical-system-path "'init-file or 'x-display" what)) + (or (wx:find-graphical-system-path what) + (case what + [(init-file) + (build-path (find-system-path 'init-dir) + (case (system-type) + [(windows) "gracketrc.rktl"] + [else ".gracketrc"]))] + [else #f]))) + (provide (all-from racket/draw)) (provide button% @@ -282,4 +293,5 @@ hide-cursor-until-moved system-position-ok-before-cancel? label-string? - key-code-symbol?)) + key-code-symbol? + find-graphical-system-path)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index ed872b4a..77866d04 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -65,7 +65,8 @@ (import-class NSScreen NSCursor) -(define-unimplemented find-graphical-system-path) +(define (find-graphical-system-path what) + #f) (define (color-from-user-platform-mode) "Show Picker") diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 86e06ef1..1dc5c903 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -13,6 +13,7 @@ "window.rkt" "frame.rkt" "dc.rkt" + "queue.rkt" "printer-dc.rkt" "gl-context.rkt" "../common/printer.rkt" @@ -59,8 +60,12 @@ fill-private-color get-color-from-user) -(define-unimplemented find-graphical-system-path) -(define-unimplemented cancel-quit) +(define (find-graphical-system-path what) + (case what + [(x-display) (string->path x11-display)] + [else #f])) + +(define (cancel-quit) (void)) (define-unimplemented play-sound) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index a37d81eb..80855f65 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -12,7 +12,8 @@ (provide (protect-out gtk-start-event-pump try-to-sync-refresh - set-widget-hook!) + set-widget-hook! + x11-display) ;; from common/queue: current-eventspace queue-event @@ -24,55 +25,57 @@ (define-gtk gtk_init_check (_fun (_ptr io _int) (_ptr io _gcpointer) -> _gboolean)) -(let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)] - [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)] - [argv (and (positive? argc) - (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))] - [display (getenv "DISPLAY")]) - ;; Convert X11 arguments, if any, to Gtk form: - (let-values ([(args single-instance?) - (if (zero? argc) - (values null #f) - (let loop ([i 1][si? #f]) - (if (= i argc) - (values null si?) - (let ([s (ptr-ref argv _bytes i)]) - (cond - [(bytes=? s #"-display") - (let-values ([(args si?) (loop (+ i 2) si?)] - [(d) (ptr-ref argv _bytes (add1 i))]) - (set! display (bytes->string/utf-8 d #\?)) - (values (list* #"--display" d args) - si?))] - [(bytes=? s #"-synchronous") - (let-values ([(args si?) (loop (+ i 1) si?)]) - (values (cons #"--sync" args) - si?))] - [(bytes=? s #"-singleInstance") - (loop (add1 i) #t)] - [(or (bytes=? s #"-iconic") - (bytes=? s #"-rv") - (bytes=? s #"+rv") - (bytes=? s #"-reverse")) - ;; ignored with 0 arguments - (loop (add1 i) #t)] - [else - ;; all other ignored flags have a single argument - (loop (+ i 2) #t)])))))]) - (let-values ([(new-argc new-argv) - (if (null? args) - (values 0 #f) - (values (add1 (length args)) - (cast (cons (ptr-ref argv _bytes 0) - args) - (_list i _bytes) - _pointer)))]) - (unless (gtk_init_check new-argc new-argv) - (error (format - "Gtk initialization failed for display ~s" - (or display ":0")))) - (when single-instance? - (do-single-instance))))) +(define x11-display + (let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)] + [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)] + [argv (and (positive? argc) + (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))] + [display (getenv "DISPLAY")]) + ;; Convert X11 arguments, if any, to Gtk form: + (let-values ([(args single-instance?) + (if (zero? argc) + (values null #f) + (let loop ([i 1][si? #f]) + (if (= i argc) + (values null si?) + (let ([s (ptr-ref argv _bytes i)]) + (cond + [(bytes=? s #"-display") + (let-values ([(args si?) (loop (+ i 2) si?)] + [(d) (ptr-ref argv _bytes (add1 i))]) + (set! display (bytes->string/utf-8 d #\?)) + (values (list* #"--display" d args) + si?))] + [(bytes=? s #"-synchronous") + (let-values ([(args si?) (loop (+ i 1) si?)]) + (values (cons #"--sync" args) + si?))] + [(bytes=? s #"-singleInstance") + (loop (add1 i) #t)] + [(or (bytes=? s #"-iconic") + (bytes=? s #"-rv") + (bytes=? s #"+rv") + (bytes=? s #"-reverse")) + ;; ignored with 0 arguments + (loop (add1 i) #t)] + [else + ;; all other ignored flags have a single argument + (loop (+ i 2) #t)])))))]) + (let-values ([(new-argc new-argv) + (if (null? args) + (values 0 #f) + (values (add1 (length args)) + (cast (cons (ptr-ref argv _bytes 0) + args) + (_list i _bytes) + _pointer)))]) + (unless (gtk_init_check new-argc new-argv) + (error (format + "Gtk initialization failed for display ~s" + (or display ":0")))) + (when single-instance? + (do-single-instance)) + display)))) ;; ------------------------------------------------------------ ;; Gtk event pump diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 8ec87a93..c88d403c 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -60,8 +60,10 @@ get-color-from-user) -(define-unimplemented find-graphical-system-path) -(define-unimplemented cancel-quit) +(define (find-graphical-system-path what) + #f) + +(define (cancel-quit) (void)) (define (color-from-user-platform-mode) 'dialog) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 64bbb43c..fa69a652 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -56,8 +56,8 @@ The get operation always returns @racket[#"????"] and @racket[#"????"] for Windows. } -@defproc[(find-graphical-system-path [what (one-of/c 'init-file 'setup-file 'x-display)]) - (or/c path? false/c)]{ +@defproc[(find-graphical-system-path [what (one-of/c 'init-file 'x-display)]) + (or/c path? #f)]{ Finds a platform-specific (and possibly user- or machine-specific) standard filename or directory. See also @racket[find-system-path]. @@ -75,7 +75,7 @@ The result depends on @racket[what], and a @racket[#f] result is only @itemize[ @item{@|AllUnix|: @indexed-file{.gracketrc}} - @item{Windows: @indexed-file{racketrc.rktl}} + @item{Windows: @indexed-file{gracketrc.rktl}} ]} From a23671380fbbd8638e898446389ea6c37a66a9d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Nov 2010 07:16:12 -0700 Subject: [PATCH 361/462] gtk: initialize canvas backing to white original commit: 23908c23728d16cb3b7e1799180f4d6e5e5965c5 --- collects/mred/private/wx/gtk/dc.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 518ca143..ed66511f 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -38,6 +38,12 @@ w h)) + ;; initialize bitmap to white: + (let ([cr (cairo_create s)]) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + ;; `get-gdk-pixmap' and `install-gl-context' are ;; localized in "gl-context.rkt" (define/public (get-gdk-pixmap) pixmap) From 421f1330666a0e225a14f72d6c6f16a409381744 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 7 Nov 2010 12:06:34 -0700 Subject: [PATCH 362/462] add dx offset when drawing original commit: 74fce96d9242a559c3aed6461b1821e6cbe9ec12 --- collects/framework/private/text.rkt | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 45a5f49f..722ad4eb 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3825,7 +3825,7 @@ designates the character that triggers autocompletion (min 255 (integer (* 255 green))) (min 255 (integer (* 255 blue))))) - (define (draw-numbers dc top bottom dy start-line end-line) + (define (draw-numbers dc top bottom dx dy start-line end-line) (define (draw-text . args) (send/apply dc draw-text args)) @@ -3839,10 +3839,11 @@ designates the character that triggers autocompletion (when (between top y bottom) (define view (number->string (add1 (line-paragraph line)))) (define final-x - (case alignment - [(left) 0] - [(right) (- right-space (text-width dc view) single-space)] - [else 0])) + (+ dx + (case alignment + [(left) 0] + [(right) (- right-space (text-width dc view) single-space)] + [else 0]))) (define final-y (+ dy y)) (if (and last-paragraph (= last-paragraph (line-paragraph line))) (begin @@ -3854,8 +3855,8 @@ designates the character that triggers autocompletion (set! last-paragraph (line-paragraph line)))) ;; draw the line between the line numbers and the actual text - (define (draw-separator dc top bottom dy x) - (send dc draw-line x (+ dy top) x (+ dy bottom))) + (define (draw-separator dc top bottom dx dy x) + (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom))) (define line-numbers-space 0) (define/override (find-position x y . args) @@ -3871,8 +3872,8 @@ designates the character that triggers autocompletion (get-visible-line-range start-line end-line #f) ;; draw it! - (draw-numbers dc top bottom dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dy (text-width dc (number-space)))) + (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) + (draw-separator dc top bottom dx dy (text-width dc (number-space)))) (define (text-width dc stuff) (define-values (font-width font-height baseline space) From c9ec791df0f3ac7db753b975f02d245657a12562 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 7 Nov 2010 12:19:49 -0700 Subject: [PATCH 363/462] check last-line + 1 original commit: 96018f258c406e55b98dd4d02f2c2248ad38daea --- collects/framework/private/text.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 722ad4eb..208e1a1a 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3726,7 +3726,7 @@ designates the character that triggers autocompletion (init-field [alignment 'right]) (define (number-space) - (number->string (max (* 10 (last-line)) 100))) + (number->string (max (* 10 (add1 (last-line))) 100))) ;; add an extra 0 so it looks nice (define (number-space+1) (string-append (number-space) "0")) From 1a852b22ede6d87151d78752501680222ec1d93a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 07:03:51 -0700 Subject: [PATCH 364/462] cocoa: fix ctl-\ key event original commit: 3747978c1e8d5d3fa4fcd8ba5a91a5618af9c97a --- collects/mred/private/wx/cocoa/window.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b4daaa97..ef9bebe3 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -248,7 +248,7 @@ #\nul (let ([c (string-ref str 0)]) (or (and control? - (char<=? #\u00 c #\u1a) + (char<=? #\u00 c #\u1F) (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) (and (string? alt-str) (= 1 (string-length alt-str)) From dceffd7feebd94dade3d40bc3f0e63b0f7c48ccd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 07:12:03 -0700 Subject: [PATCH 365/462] cocoa: fix save-file dialog when other extensions should be allowed original commit: 83bcdbbd8122c688f02685d212daa621b86a6174 --- collects/mred/private/wx/cocoa/filedialog.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 00e124e4..22d161ac 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -42,10 +42,10 @@ arrayWithObjects: #:type (_list i _NSString) extensions count: #:type _NSUInteger (length extensions))]) (tellv ns setAllowedFileTypes: a)))) - (when (not (ormap (lambda (e) - (equal? (cadr e) "*.*")) - filters)) - (tellv ns setAllowsOtherFileTypes: #:type _BOOL #f)) + (let ([others? (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)]) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)) (cond [(memq 'multi style) From 6306af91debf12f84ee3ad3be05259ce4927bba3 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 8 Nov 2010 13:19:21 -0700 Subject: [PATCH 366/462] set pen to black so the line separator is drawn in the right color original commit: d920cdc945e8455e33a55fb26b2b7c3f3ccfb9c2 --- collects/framework/private/text.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 208e1a1a..1fed7120 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3758,6 +3758,7 @@ designates the character that triggers autocompletion ;; set the dc stuff to values we want (define (setup-dc dc) + (send dc set-pen "black" 1 'solid) (send dc set-font (get-style-font)) (send dc set-text-foreground (make-object color% line-numbers-color))) From 5205ca7906fdb814e59dafb07c4a8ee162e3f4c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 20:43:28 -0700 Subject: [PATCH 367/462] cocoa: use alternate key if ctl-combination has no mapping --- fixes ctl-space, and maybe other combinations Closes PR 11403 original commit: c9b7c98525e8f4e1a42e69f8c5f8cbd545f9288b --- collects/mred/private/wx/cocoa/window.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ef9bebe3..03a199b0 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -269,8 +269,10 @@ (let ([alt-code (string-ref alt-str 0)]) (unless (equal? alt-code (send k get-key-code)) (send k set-other-altgr-key-code alt-code))))) - (when (and option? - special-option-key? + (when (and (or (and option? + special-option-key?) + (and control? + (equal? (send k get-key-code) #\u00))) (send k get-other-altgr-key-code)) ;; swap altenate with main (let ([other (send k get-other-altgr-key-code)]) From 570a0957a58ce7ea4e1f48cf6153f2334faf7ade Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 8 Nov 2010 08:51:06 -0600 Subject: [PATCH 368/462] add .scrbl to liked extensions in drracket original commit: e9c90dc580a4a49132dc7ec33b9380708888e954 --- collects/framework/private/scheme.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index 5d46dc65..e9da20f0 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -1220,7 +1220,7 @@ (define/override (put-file text sup directory default-name) (parameterize ([finder:default-extension "rkt"] - [finder:default-filters '(["Racket Sources" "*.rkt;*.ss;*.scm"] + [finder:default-filters '(["Racket Sources" "*.rkt;*.scrbl;*.ss;*.scm"] ["Any" "*.*"])]) ;; don't call the surrogate's super, since it sets the default extension (sup directory default-name))) From d20c5fbd4af3e7c6b568f7f342c66cbe73754cce Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 9 Nov 2010 16:59:01 -0700 Subject: [PATCH 369/462] use #x3FFFFFF instead of #x3FFFFFFF for max size of an unbounded frame because sawfish is unhappy with #x3FFFFFFF original commit: 168a2c15911a2bc6abd249a9a557e90ee5b0d4d9 --- collects/mred/private/wx/gtk/frame.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 34916efb..c1c43315 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -213,7 +213,7 @@ (define saved-enforcements (vector 0 0 -1 -1)) (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) - (define (to-max v) (if (= v -1) #x3FFFFFFF v)) + (define (to-max v) (if (= v -1) #x3FFFFF v)) (set! saved-enforcements (vector min-x min-y max-x max-y)) (gtk_window_set_geometry_hints gtk gtk (make-GdkGeometry min-x min-y From 6563ae1fc31ab54330e0e588051a7fb0b32c97cc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 8 Nov 2010 12:41:57 -0500 Subject: [PATCH 370/462] drop "www." from "racket-lang.org" urls. original commit: 8e0c7477f617c4830f26f1d7e42358f7f0e32eac --- man/man1/gracket.1 | 2 +- man/man1/mred.1 | 2 +- man/man1/mzscheme.1 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/man/man1/gracket.1 b/man/man1/gracket.1 index e638647b..d07e1a8b 100644 --- a/man/man1/gracket.1 +++ b/man/man1/gracket.1 @@ -48,7 +48,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH AUTHOR GRacket was implemented by Matthew Flatt (mflatt@racket-lang.org), diff --git a/man/man1/mred.1 b/man/man1/mred.1 index 4c46b27a..ca8f3557 100644 --- a/man/man1/mred.1 +++ b/man/man1/mred.1 @@ -33,7 +33,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH SEE ALSO .BR gracket(1) diff --git a/man/man1/mzscheme.1 b/man/man1/mzscheme.1 index ae104ad2..32224a73 100644 --- a/man/man1/mzscheme.1 +++ b/man/man1/mzscheme.1 @@ -33,7 +33,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH SEE ALSO .BR racket(1) From f83d833348e2555074d6a23c6c2b61c059c924a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 10 Nov 2010 16:47:09 -0700 Subject: [PATCH 371/462] cocoa: avoid 10.6-specific method for menu popup original commit: b6b3298567c4aa566a93ed46f76eb2774d37a0fa --- collects/mred/private/wx/cocoa/menu.rkt | 35 +++++++++++++++++++---- collects/mred/private/wx/cocoa/queue.rkt | 2 +- collects/mred/private/wx/cocoa/window.rkt | 2 +- 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 8d59c1f3..a7b8bd31 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -5,15 +5,17 @@ (only-in scheme/list drop take) "../common/event.rkt" "../../syntax.rkt" + "../../lock.rkt" "utils.rkt" "types.rkt" + "const.rkt" "window.rkt" "menu-item.rkt") (provide (protect-out menu%)) -(import-class NSMenu NSMenuItem) +(import-class NSMenu NSMenuItem NSEvent) (define-struct mitem (item checkable?)) @@ -56,15 +58,36 @@ (define popup-box #f) - (define/public (do-popup v x y queue-cb) + (define/public (do-popup v win x y queue-cb) (unless (null? items) (create-menu "menu") (let ([b (box #f)]) (set! popup-box b) - (tellv cocoa-menu - popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0) - atLocation: #:type _NSPoint (make-NSPoint x y) - inView: v) + (if #t ;; use the 10.5 code, for now + ;; For 10.5 and earlier: + (let ([p (tell #:type _NSPoint v + convertPoint: #:type _NSPoint (make-NSPoint x y) + toView: #f)]) + (atomically + (with-autorelease + (tellv NSMenu popUpContextMenu: cocoa-menu + withEvent: (tell NSEvent + mouseEventWithType: #:type _int NSLeftMouseDown + location: #:type _NSPoint p + modifierFlags: #:type _NSUInteger 0 + timestamp: #:type _double 0.0 + windowNumber: #:type _NSUInteger + (tell #:type _NSInteger win windowNumber) + context: #:type _pointer #f + eventNumber: #:type _NSInteger 0 + clickCount: #:type _NSInteger 1 + pressure: #:type _float 1.0) + forView: v)))) + ;; 10.6 and later: + (tellv cocoa-menu + popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0) + atLocation: #:type _NSPoint (make-NSPoint x y) + inView: v)) (set! popup-box #f) (let* ([i (unbox b)] [e (new popup-event% [event-type 'menu-popdown])]) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 5be58666..654b8cca 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -103,7 +103,7 @@ (define wake-evt (tell NSEvent otherEventWithType: #:type _int NSApplicationDefined - location: #:type _NSPoint-pointer (make-NSPoint 0.0 0.0) + location: #:type _NSPoint (make-NSPoint 0.0 0.0) modifierFlags: #:type _NSUInteger 0 timestamp: #:type _double 0.0 windowNumber: #:type _NSUInteger 0 diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 03a199b0..42435566 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -650,7 +650,7 @@ (define/public (get-handle) (get-cocoa)) (define/public (popup-menu m x y) - (send m do-popup (get-cocoa-content) x (flip-client y) + (send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y) (lambda (thunk) (queue-window-event this thunk)))) From 68fbeb7cde4dd2c48d427b6593d3e9939c33f6e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 10 Nov 2010 17:48:29 -0700 Subject: [PATCH 372/462] cocoa: set button control size when font is small Closes PR 11404 original commit: d7369f819c014ab15da4b9dc23c6a4ac7f0f5664 --- collects/mred/private/wx/cocoa/button.rkt | 11 +++++++++++ collects/mred/private/wx/cocoa/frame.rkt | 12 ++++++------ collects/mred/private/wx/cocoa/item.rkt | 13 ++++++++++--- 3 files changed, 27 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index b58f18e3..48e97919 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -23,6 +23,9 @@ (define MIN-BUTTON-WIDTH 72) (define BUTTON-EXTRA-WIDTH 12) +(define NSSmallControlSize 1) +(define NSMiniControlSize 2) + (define-objc-class MyButton NSButton #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] @@ -61,6 +64,14 @@ (tellv cocoa sizeToFit) (when (and (eq? event-type 'button) (string? label)) + (when font + (let ([n (send font get-point-size)]) + (when (n . < . sys-font-size) + (tellv (tell cocoa cell) + setControlSize: #:type _int + (if (n . < . (- sys-font-size 2)) + NSMiniControlSize + NSSmallControlSize))))) (let ([frame (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (NSRect-origin frame) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 8d585a77..7779a020 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -244,12 +244,12 @@ (not (send p get-sheet))))) (let ([p (get-parent)]) (send p set-sheet this) - (tell (tell NSApplication sharedApplication) - beginSheet: cocoa - modalForWindow: (send p get-cocoa) - modalDelegate: #f - didEndSelector: #:type _SEL #f - contextInfo: #f)) + (tellv (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) (tellv cocoa makeKeyAndOrderFront: #f)) (begin (when is-a-dialog? diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 674da458..e04a3751 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -3,6 +3,7 @@ ffi/unsafe ffi/unsafe/objc "../../syntax.rkt" + "../../lock.rkt" "window.rkt" "const.rkt" "types.rkt" @@ -10,11 +11,17 @@ (provide (protect-out item% - install-control-font)) + install-control-font + sys-font-size)) (import-class NSFont) -(define sys-font (tell NSFont - systemFontOfSize: #:type _CGFloat 13)) + +(define sys-font-size 13) +(define sys-font + (atomically + (let ([f (tell NSFont systemFontOfSize: #:type _CGFloat sys-font-size)]) + (tellv f retain) + f))) (define (install-control-font cocoa font) (if font From bba9d6f5f3f9be2e8eea78681992e0c9de453c9f Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 11 Nov 2010 13:29:01 -0700 Subject: [PATCH 373/462] increase delay value before refresh to 100 original commit: bcef0dbfe24662369ce148ec87d90d5d828ad0be --- collects/mred/private/wx/common/queue.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 61e6832c..5041babc 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -128,7 +128,7 @@ (alert-tasks-ready))) (define last-time -inf.0) -(define sometimes-delay-msec 50) +(define sometimes-delay-msec 100) ;; Call this function only in atomic mode: (define (pre-event-sync force?) From 624863e760944ef45a4bd69e52831dcf0f699b91 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:39:58 -0700 Subject: [PATCH 374/462] adjust canvas refresh strategy yet again - there seems to be no need to auto-resume flushes on a canvas, which can create flicker if the auto-resume timeout turns out to be too short original commit: 1c6f745ac162c91532c75e2bb0a0922c4b3fefab --- collects/mred/private/wx/cocoa/canvas.rkt | 6 ++++-- collects/mred/private/wx/cocoa/dc.rkt | 17 ++++++--------- collects/mred/private/wx/common/delay.rkt | 26 ++++++++++++++++------- 3 files changed, 29 insertions(+), 20 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e791fc55..7488e490 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -272,9 +272,11 @@ ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) (define/public (request-canvas-flush-delay) - (request-flush-delay (get-cocoa-window))) + (unless is-gl? + (request-flush-delay (get-cocoa-window)))) (define/public (cancel-canvas-flush-delay req) - (cancel-flush-delay req)) + (unless is-gl? + (cancel-flush-delay req))) (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b6c04bf0..b739fa88 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -26,6 +26,7 @@ (init [(cnvs canvas)]) (define canvas cnvs) + (inherit end-delay) (super-new) (define gl #f) @@ -59,21 +60,18 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; With Cocoa window-level delay doesn't stop - ;; displays; it blocks flushes to the screen. - ;; So leave the delay in place, and `end-delay' - ;; after displaying to the window (after which - ;; we'll be ready to flush the window), which - ;; is at then end of `do-backing-flush'. + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) (send canvas queue-backing-flush)) (define/override (flush) (send canvas flush)) (define/override (request-delay) - (request-flush-delay (send canvas get-flush-window))) + (send canvas request-canvas-flush-delay)) (define/override (cancel-delay req) - (cancel-flush-delay req)))) + (send canvas cancel-canvas-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) @@ -99,6 +97,5 @@ (cairo_fill cr) (cairo_set_source cr s) (cairo_pattern_destroy s)) - (cairo_destroy cr)))) - (send dc end-delay))) + (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index 7898a2d3..ef8d7044 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -6,19 +6,28 @@ (protect-out do-request-flush-delay do-cancel-flush-delay)) +;; Auto-cancel schedules a cancel of a request flush +;; on event boundaries. It makes sense if you don't +;; trust a program to un-delay important refreshes, +;; but auto-cancel is currently disabled because +;; bad refresh-delay effects are confined to the enclosing +;; window on all platforms. +(define AUTO-CANCEL-DELAY? #f) + (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) (and (disable win) (begin - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) + (when AUTO-CANCEL-DELAY? + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win))))) req))))) (define (do-cancel-flush-delay req enable) @@ -27,4 +36,5 @@ (when win (set-box! req #f) (enable win) - (remove-event-boundary-callback! req))))) + (when AUTO-CANCEL-DELAY? + (remove-event-boundary-callback! req)))))) From f7297e95fece4d01e6cc269f0c7da1df7ca25394 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:47:07 -0700 Subject: [PATCH 375/462] manual tests for refresh behavior original commit: c3e0a7af139ab44e1bc7f46a4de9de5a582f98ea --- collects/tests/gracket/flush-stress.rkt | 50 +++++++++++++++++++++ collects/tests/gracket/unflushed-circle.rkt | 43 ++++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 collects/tests/gracket/flush-stress.rkt create mode 100644 collects/tests/gracket/unflushed-circle.rkt diff --git a/collects/tests/gracket/flush-stress.rkt b/collects/tests/gracket/flush-stress.rkt new file mode 100644 index 00000000..cddbaff6 --- /dev/null +++ b/collects/tests/gracket/flush-stress.rkt @@ -0,0 +1,50 @@ +#lang racket/gui + +(define SIZE 600) + +(define f (new frame% + [label "Color Bars"] + [width SIZE] + [height SIZE])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +;; If sync is turned off, then expect the drawing +;; to flicker horribly: +(define sync? #t) + +;; If flush-on-sync is disabled, the expect refresh +;; to starve, so that the image moves very rarely, if +;; at all: +(define flush-on-sync? #t) + +(define (start-drawing dc) + (when sync? + (send dc suspend-flush))) + +(define (end-drawing dc) + (when sync? + (send dc resume-flush) + (when flush-on-sync? + (send dc flush)))) + +(define (go) + (let ([dc (send c get-dc)]) + (for ([d (in-naturals)]) + (start-drawing dc) + (send dc erase) + ;; Draw somthing slow that changes with d + (for ([n (in-range 0 SIZE)]) + (send dc set-pen + (make-object color% + (remainder (+ n d) 256) + (remainder (* 2 (+ n d)) 256) + (remainder (* 3 (+ n d)) 256)) + 1 + 'solid) + (send dc draw-line n 0 n SIZE)) + (end-drawing dc)))) + +(thread go) diff --git a/collects/tests/gracket/unflushed-circle.rkt b/collects/tests/gracket/unflushed-circle.rkt new file mode 100644 index 00000000..7376ed62 --- /dev/null +++ b/collects/tests/gracket/unflushed-circle.rkt @@ -0,0 +1,43 @@ +#lang racket/gui +(require racket/math) + +;; This test creates a background that draws a circle in changing +;; colors. It draws in a background thread --- on in response to +;; `on-paint', and with no flushing controls --- but it should nevertheless +;; refresh onscreen frequently through an automatic flush. + +(define f (new frame% + [label "Snake"] + [width 400] + [height 400])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +(define prev-count 0) +(define next-time (+ (current-inexact-milliseconds) 1000)) + +(define (go) + (let loop ([n 0]) + (when ((current-inexact-milliseconds) . > . next-time) + (printf "~s\n" (- n prev-count)) + (set! prev-count n) + (set! next-time (+ (current-inexact-milliseconds) 1000))) + (let ([p (make-polar 175 (* pi (/ n 100)))] + [dc (send c get-dc)]) + (send dc set-brush + (make-object color% + (remainder n 256) + (remainder (* 2 n) 256) + (remainder (* 3 n) 256)) + 'solid) + (send dc draw-rectangle + (+ 180 (real-part p)) + (+ 180 (imag-part p)) + 20 + 20) + (loop (add1 n))))) + +(thread go) + From 95048b2dca1925903f66b07f27d8a781a39d9912 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 13 Nov 2010 09:54:14 -0700 Subject: [PATCH 376/462] win32: canvas refresh repair original commit: d2fe39da339c06c3f7edfe57ea53e5543101957b --- .../mred/private/wx/common/canvas-mixin.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 53 ++++++++++++------- 2 files changed, 36 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 1dbeb28e..07c4364f 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -168,7 +168,7 @@ (define flush-box #f) - ;; Periodic flush is needed for Windows and Gtk, where + ;; Periodic flush is needed for Windows, where ;; updates otherwise happen only via the eventspace's queue (define/override (schedule-periodic-backing-flush) (unless flush-box diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index e871aeb2..cfaf727a 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -157,19 +157,20 @@ [hdc (BeginPaint w ps)]) (if for-gl? (queue-paint) - (unless (positive? paint-suspended) - (let* ([hbrush (if no-autoclear? - #f - (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref)))]) - (when hbrush - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush))) - (unless (do-canvas-backing-flush hdc) - (queue-paint))))) + (if (positive? paint-suspended) + (set! suspended-refresh? #t) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-canvas-backing-flush hdc) + (queue-paint))))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -271,22 +272,38 @@ (define/public (do-canvas-backing-flush hdc) (if hdc (do-backing-flush this dc hdc) - (let ([hdc (GetDC canvas-hwnd)]) - (do-backing-flush this dc hdc) - (ReleaseDC canvas-hwnd hdc) - (ValidateRect canvas-hwnd #f)))) + (if (positive? paint-suspended) + ;; suspended => try again later + (schedule-periodic-backing-flush) + ;; not suspended + (let ([hdc (GetDC canvas-hwnd)]) + (do-backing-flush this dc hdc) + (ReleaseDC canvas-hwnd hdc) + ;; We'd like to validate the region that + ;; we just updated, so we can potentially + ;; avoid a redundant refresh. For some reason, + ;; vadilation can cancel an update that hasn't + ;; happened, yet; this problem needs further + ;; invesitigation. + #; + (ValidateRect canvas-hwnd #f))))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) (define paint-suspended 0) + (define suspended-refresh? #f) (define/public (suspend-paint-handling) (atomically (set! paint-suspended (add1 paint-suspended)))) (define/public (resume-paint-handling) (atomically (unless (zero? paint-suspended) - (set! paint-suspended (sub1 paint-suspended))))) + (set! paint-suspended (sub1 paint-suspended)) + (when (and (zero? paint-suspended) + suspended-refresh?) + (set! suspended-refresh? #f) + (InvalidateRect canvas-hwnd #f #f))))) (define no-autoclear? (memq 'no-autoclear style)) (define transparent? (memq 'transparent style)) From 27009c62e2aff3eca7716b3d31cd985929314998 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 11:38:28 -0700 Subject: [PATCH 377/462] cocoa: fix ffi-use bug original commit: 279315b582115b7af4ad4821ca5bfb097c53f83b --- collects/mred/private/wx/cocoa/finfo.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index b4090a9f..dad503cb 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -112,7 +112,7 @@ v #f #f #f)]) (unless (zero? r) - (error 'file-creator-and-file "lookup failed (~a): ~e" + (error 'file-creator-and-type "lookup failed (~a): ~e" r path)))) @@ -122,7 +122,7 @@ (unless (path-string? path) (raise-type-error 'file-creator-and-type "path string" path)) (let ([info (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (FSCatalogInfo-finderInfo v))]) (values (int->str (FileInfo-fileCreator info)) @@ -135,7 +135,7 @@ (unless (and (bytes? type) (= 4 (bytes-length type))) (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (let ([info (FSCatalogInfo-finderInfo v)]) (set-FileInfo-fileCreator! info (str->int creator)) @@ -144,7 +144,7 @@ kFSCatInfoFinderInfo v)]) (unless (zero? r) - (error 'file-creator-and-file "change failed (~a): ~e" + (error 'file-creator-and-type "change failed (~a): ~e" r path)))) (void)])) From e28237cccbcbf9e4220f380dea0c474e50997785 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 15:46:41 -0700 Subject: [PATCH 378/462] cocoa: avoid explicit NSTabViewDelegate --- not in pre-10.6, seems to crash in 64-bit mode, and not necessary to declare Closes PR 11418 original commit: 16b75b1f0044d3352bb2ba0e8f7031b8279cf4c0 --- collects/mred/private/wx/cocoa/README.txt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt index b989a697..df66a5c0 100644 --- a/collects/mred/private/wx/cocoa/README.txt +++ b/collects/mred/private/wx/cocoa/README.txt @@ -3,7 +3,7 @@ Allocation rules: * Use `as-objc-allocation' when creating a Cocoa object. When the resulting reference becomes unreachable, the Cocoa object will be - releaset. + released. * Use `with-autorelease' in atomic mode around calls that autorelease and where the release should take effect immediate. Do not create diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 62a22c5e..d67e669e 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -28,7 +28,6 @@ (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) - #:protocols (NSTabViewDelegate) [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) @@ -50,7 +49,8 @@ (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) (define cocoa (if (not (memq 'border style)) - (tell (tell NSView alloc) init) + (as-objc-allocation + (tell (tell NSView alloc) init)) tabv-cocoa)) (define control-cocoa From 68bae9195e1c72450dae40e657bb8e9364c63e68 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 14 Nov 2010 19:44:42 -0700 Subject: [PATCH 379/462] save/restore dc state while drawing line numbers original commit: ee62bae74be7c59479a19ac4b81fed1c03df90b9 --- collects/framework/private/text.rkt | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 1fed7120..63d514e0 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3756,6 +3756,17 @@ designates the character that triggers autocompletion (and (>= what low) (<= what high))) + (define-struct saved-dc-state (pen font foreground-color)) + (define (save-dc-state dc) + (saved-dc-state (send dc get-pen) + (send dc get-font) + (send dc get-text-foreground))) + + (define (restore-dc-state dc dc-state) + (send dc set-pen (saved-dc-state-pen dc-state)) + (send dc set-font (saved-dc-state-font dc-state)) + (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) + ;; set the dc stuff to values we want (define (setup-dc dc) (send dc set-pen "black" 1 'solid) @@ -3859,6 +3870,7 @@ designates the character that triggers autocompletion (define (draw-separator dc top bottom dx dy x) (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom))) + ;; `line-numbers-space' will get mutated in the `on-paint' method (define line-numbers-space 0) (define/override (find-position x y . args) ;; adjust x position to account for line numbers @@ -3867,6 +3879,7 @@ designates the character that triggers autocompletion (super find-position x y . args))) (define (draw-line-numbers dc left top right bottom dx dy) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define start-line (box 0)) (define end-line (box 0)) @@ -3874,7 +3887,8 @@ designates the character that triggers autocompletion ;; draw it! (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dx dy (text-width dc (number-space)))) + (draw-separator dc top bottom dx dy (text-width dc (number-space))) + (restore-dc-state dc saved-dc)) (define (text-width dc stuff) (define-values (font-width font-height baseline space) @@ -3897,14 +3911,17 @@ designates the character that triggers autocompletion ;; will probably go away when 'margin's are added to editors ;; ;; save old origin and push it to the right a little bit - ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + ;; TODO: maybe allow the line numbers to be drawn on the right hand side + ;; of the editor? (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) (set! old-clipping (send dc get-clipping-region)) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define-values (font-width font-height baseline space) (send dc get-text-extent (number-space))) + (restore-dc-state dc saved-dc) (define clipped (make-object region% dc)) (define all (make-object region% dc)) (define copy (make-object region% dc)) From b243414450c8f4a057bac9443d5ae2b1f1cf0b31 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 18:10:00 -0700 Subject: [PATCH 380/462] cocoa: adjust button shape for large fonts original commit: 6c844ec41555d3ef381024d43993d16da85db5fc --- collects/mred/private/wx/cocoa/button.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 48e97919..94cf0f6a 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -66,12 +66,18 @@ (string? label)) (when font (let ([n (send font get-point-size)]) + ;; If the font is small, adjust the control size: (when (n . < . sys-font-size) (tellv (tell cocoa cell) setControlSize: #:type _int (if (n . < . (- sys-font-size 2)) NSMiniControlSize - NSSmallControlSize))))) + NSSmallControlSize)) + (tellv cocoa sizeToFit)) + ;; If the font is big, use a scalable control shape: + (when (n . > . (+ sys-font-size 2)) + (tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle) + (tellv cocoa sizeToFit)))) (let ([frame (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (NSRect-origin frame) From 4737e58099f32d999e7b9982f3563008c24369e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Nov 2010 19:46:41 -0700 Subject: [PATCH 381/462] cocoa: fix put-file extension handling when no extensions are supplied original commit: f050f28d2b10832630dcd933e53bc13b602b477a --- collects/mred/private/wx/cocoa/filedialog.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 22d161ac..d73cc60d 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -41,11 +41,11 @@ (let ([a (tell NSArray arrayWithObjects: #:type (_list i _NSString) extensions count: #:type _NSUInteger (length extensions))]) - (tellv ns setAllowedFileTypes: a)))) - (let ([others? (ormap (lambda (e) - (equal? (cadr e) "*.*")) - filters)]) - (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)) + (tellv ns setAllowedFileTypes: a)) + (let ([others? (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)]) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)))) (cond [(memq 'multi style) From 277c10793ab7b820feaaeb6011ed1b209391dedf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Nov 2010 17:08:14 -0700 Subject: [PATCH 382/462] cocoa: avoid another 10.6-only method Closes PR 11440 original commit: 584287483b0aae37174cfa8cc65589203bff2cdd --- collects/mred/private/wx/cocoa/filedialog.rkt | 4 +++- collects/mred/private/wx/cocoa/menu.rkt | 2 +- collects/mred/private/wx/cocoa/utils.rkt | 13 +++++++++---- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index d73cc60d..7ffc630d 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -74,7 +74,9 @@ ;; all other eventspaces and threads. It would be nice to improve ;; on this, but it's good enough. (atomically - (let ([front (get-front)]) + (let ([front (get-front)] + [parent (and (version-10.6-or-later?) + parent)]) (when parent (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) completionHandler: #f)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index a7b8bd31..0162bc21 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -63,7 +63,7 @@ (create-menu "menu") (let ([b (box #f)]) (set! popup-box b) - (if #t ;; use the 10.5 code, for now + (if (not (version-10.6-or-later?)) ;; For 10.5 and earlier: (let ([p (tell #:type _NSPoint v convertPoint: #:type _NSPoint (make-NSPoint x y) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 02d1a0b0..fff2a032 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -21,7 +21,8 @@ clean-menu-label ->wxb ->wx - old-cocoa?) + old-cocoa? + version-10.6-or-later?) define-mz) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) @@ -79,6 +80,10 @@ (and wxb (weak-box-value wxb))) -;; FIXME: need a better test: -(define old-cocoa? (equal? (path->string (system-library-subpath #f)) - "ppc-macosx")) +(define-appkit NSAppKitVersionNumber _double) + +(define old-cocoa? + ; earlier than 10.5? + (NSAppKitVersionNumber . < . 949)) +(define (version-10.6-or-later?) + (NSAppKitVersionNumber . >= . 1038)) From 46fac3892bcb9842a7ae8a3354df2f97771549e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Nov 2010 15:37:02 -0700 Subject: [PATCH 383/462] cocoa: avoid another 10.6-only method Closes PR 11442 original commit: bf9b913f33adaeaec494739a4c1a68a727eb939f --- collects/mred/private/wx/cocoa/filedialog.rkt | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 7ffc630d..419bc4eb 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -57,11 +57,14 @@ (when message (tellv ns setMessage: #:type _NSString message)) (when directory - (tellv ns setDirectoryURL: (tell NSURL - fileURLWithPath: #:type _NSString (if (string? directory) - directory - (path->string directory)) - isDirectory: #:type _BOOL #t))) + (let ([dir (if (string? directory) + directory + (path->string directory))]) + (if (version-10.6-or-later?) + (tellv ns setDirectoryURL: (tell NSURL + fileURLWithPath: #:type _NSString dir + isDirectory: #:type _BOOL #t)) + (tellv ns setDirectory: #:type _NSString dir)))) (when filename (tellv ns setNameFieldStringValue: #:type _NSString (path->string (file-name-from-path filename)))) From 9fa0057c3b3d798a54eca5e8c4aa16761dad69d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Nov 2010 15:45:28 -0700 Subject: [PATCH 384/462] cocoa: one more 10.6-only method original commit: c94df207a4678224b30f9746f533ca84a739fe45 --- collects/mred/private/wx/cocoa/filedialog.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 419bc4eb..3e6d35d1 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -66,9 +66,10 @@ isDirectory: #:type _BOOL #t)) (tellv ns setDirectory: #:type _NSString dir)))) (when filename - (tellv ns setNameFieldStringValue: #:type _NSString (path->string - (file-name-from-path filename)))) - + (when (version-10.6-or-later?) + (tellv ns setNameFieldStringValue: #:type _NSString (path->string + (file-name-from-path filename))))) + (when (memq 'enter-packages style) (tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t)) From 93b21b51b167178bbb53c77d4c34c3da420de673 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Nov 2010 10:02:45 -0700 Subject: [PATCH 385/462] cocoa: try to fix problem with drifting gc-blit window original commit: 510c3f8a3362fe67979e805910b90c5bd440f586 --- collects/mred/private/wx/cocoa/canvas.rkt | 5 +++++ collects/mred/private/wx/cocoa/frame.rkt | 8 ++++++++ collects/mred/private/wx/cocoa/panel.rkt | 4 ++++ collects/mred/private/wx/cocoa/queue.rkt | 8 ++++++-- collects/mred/private/wx/cocoa/window.rkt | 2 ++ 5 files changed, 25 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7488e490..34f80512 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -404,6 +404,11 @@ (super show-children) (resume-all-reg-blits)) + (define/override (fixup-locations-children) + ;; in atomic mode + (suspend-all-reg-blits) + (resume-all-reg-blits)) + (define/private (do-set-size x y w h) (when (pair? blits) (atomically (suspend-all-reg-blits))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7779a020..3956ed8f 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -319,6 +319,9 @@ (define/override (show-children) (when saved-child (send saved-child show-children))) + (define/override (fixup-locations-children) + (when saved-child + (send saved-child fixup-locations-children))) (define/override (children-accept-drag on?) (when saved-child @@ -532,3 +535,8 @@ (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) belowWindowWithWindowNumber: #:type _NSInteger 0)]) (atomically (hash-ref all-windows n #f)))) + +(set-fixup-window-locations! + (lambda () + (for ([f (in-hash-values all-windows)]) + (send f fixup-locations-children)))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 48a5c03f..6d57fecc 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -40,6 +40,10 @@ (define/override (show-children) (for ([child (in-list children)]) (send child show-children))) + + (define/override (fixup-locations-children) + (for ([child (in-list children)]) + (send child fixup-locations-children))) (define/override (paint-children) (for ([child (in-list children)]) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 654b8cca..651d0eea 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -19,6 +19,7 @@ set-eventspace-hook! set-front-hook! set-menu-bar-hooks! + set-fixup-window-locations! post-dummy-event try-to-sync-refresh) @@ -58,8 +59,11 @@ (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]) (parameterize ([current-custodian priviledged-custodian]) (thread (lambda () (sleep 5.0))))) - ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly - (void)]) + ;; Also need to reset blit windows, since OS may move them incorrectly: + (fixup-window-locations)]) + +(define fixup-window-locations void) +(define (set-fixup-window-locations! f) (set! fixup-window-locations f)) ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 42435566..a76e56fe 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -379,6 +379,8 @@ (focus-is-on #f)) (define/public (show-children) (void)) + (define/public (fixup-locations-children) + (void)) (define/public (fix-dc) (void)) (define/public (paint-children) From ae81fa7fb0ea03617093ce055c18b623941cc145 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 05:44:21 -0700 Subject: [PATCH 386/462] fix bitmap% `load-file' method and remove `{get,set}-gl-config' Closes PR 11460 original commit: f245b6ca29e4bed9c19d1b46e2954d405f67f9c5 --- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index ddc76d85..36c1d1ef 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -42,7 +42,9 @@ alphas; for example, drawing a line in the middle of an empty bitmap produces an image with non-zero alpha only at the drawn line. Only bitmaps created with the new `make-gl-bitmap' function support -OpenGL drawing. +OpenGL drawing. The `make-gl-bitmap' function takes a `gl-config%' as +an argument, and the `get-gl-config' and `set-gl-config' methods of +`bitmap%' have been removed. Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap', `make-screen-bitmap', and `make-gl-bitmap' functions to create From f1833d580ae9975d2cf1abb8cc7468c1d153d789 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 07:12:02 -0700 Subject: [PATCH 387/462] cocoa: fix problems with frame-list management original commit: 14a72b5a083da74b42bf5a7d54ae16a05d34e325 --- collects/mred/private/wx/cocoa/frame.rkt | 17 ++++++++++++----- collects/mred/private/wx/cocoa/printer-dc.rkt | 16 +++++++++++++--- 2 files changed, 25 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3956ed8f..b9570d25 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -36,6 +36,9 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) +;; Maps window numbers to weak boxes of frame objects; +;; the weak-box layer is needed to avoid GC-accounting +;; problems. (define all-windows (make-hash)) (define-objc-mixin (MyWindowMethods Superclass) @@ -278,12 +281,12 @@ (register-frame-shown this on?) (let ([num (tell #:type _NSInteger cocoa windowNumber)]) (if on? - (hash-set! all-windows num this) + (hash-set! all-windows num (make-weak-box this)) (hash-remove! all-windows num))) (when on? (let ([b (eventspace-wait-cursor-count (get-eventspace))]) (set-wait-cursor-mode (not (zero? b)))))) - + (define/override (show on?) (let ([es (get-eventspace)]) (when on? @@ -534,9 +537,13 @@ (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) belowWindowWithWindowNumber: #:type _NSInteger 0)]) - (atomically (hash-ref all-windows n #f)))) + (atomically (let ([b (hash-ref all-windows n #f)]) + (and b (weak-box-value b)))))) (set-fixup-window-locations! (lambda () - (for ([f (in-hash-values all-windows)]) - (send f fixup-locations-children)))) + ;; in atomic mode + (for ([b (in-hash-values all-windows)]) + (let ([f (weak-box-value b)]) + (send f fixup-locations-children))))) + diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index c1224ed1..580ad92e 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -12,6 +12,7 @@ ffi/unsafe/objc "../../lock.rkt" "dc.rkt" + "frame.rkt" "bitmap.rkt" "cg.rkt" "utils.rkt" @@ -101,8 +102,13 @@ (send pss set-native pi make-print-info) pi)))]) (install-pss-to-print-info pss print-info) - (if (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) - NSOkButton) + (if (atomically + (let ([front (get-front)]) + (begin0 + (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))) (begin (let ([o (tell #:type _int print-info orientation)]) (send pss set-orientation (if (= o NSLandscapeOrientation) @@ -195,4 +201,8 @@ (set-ivar! view-cocoa wxb (->wxb this)) - (tellv op-cocoa runOperation)))) + (atomically + (let ([front (get-front)]) + (tellv op-cocoa runOperation) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))))) From 596161d950f4484d1b25708f8cb4c60fd1adc64c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 10:38:20 -0700 Subject: [PATCH 388/462] cocoa: repair location fixup on screen change original commit: e2072d5afba7cc3c8f1572bdbdac0d7020c92237 --- collects/mred/private/wx/cocoa/frame.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index b9570d25..7e464a58 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -545,5 +545,6 @@ ;; in atomic mode (for ([b (in-hash-values all-windows)]) (let ([f (weak-box-value b)]) - (send f fixup-locations-children))))) + (when f + (send f fixup-locations-children)))))) From eb01085adfd9c656b442e9b463767791ac7833c8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 12:03:17 -0700 Subject: [PATCH 389/462] cocoa: fix problem with frame focus original commit: 370c97165a2efc2b9061c27e31b1cdf0d0a97026 --- collects/mred/private/wx/cocoa/frame.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7e464a58..58ec5565 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -271,6 +271,7 @@ (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) (and (tell #:type _BOOL win isVisible) + (not (tell win parentWindow)) (or (not root-fake-frame) (not (ptr-equal? win (send root-fake-frame get-cocoa)))) win)))))))]) From 439d046c98bfa035cf1d1907e6c71c123a757aa0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Nov 2010 06:52:46 -0600 Subject: [PATCH 390/462] a (failed) attempt to fix equality comparison (but at least it is a step in the right direction (I think)) original commit: a658a7620b268edef2fe2af014b0e8a892619393 --- collects/mrlib/image-core.rkt | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 0190fbf9..b9b0057f 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -214,26 +214,20 @@ has been moved out). (equal? (get-normalized-shape) (send that get-normalized-shape))) (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. - (or (zero? w) - (zero? h) - (let ([bm1 (make-object bitmap% w h)] - [bm2 (make-object bitmap% w h)] + (or ;(zero? w) + ;(zero? h) + (let ([bm1 (make-bitmap w h #t)] + [bm2 (make-bitmap w h #t)] [bytes1 (make-bytes (* w h 4) 0)] [bytes2 (make-bytes (* w h 4) 0)] [bdc (make-object bitmap-dc%)]) - (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that) - (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))) + (draw-into bm1 bdc bytes1 this) + (draw-into bm2 bdc bytes2 that) + (equal? bytes1 bytes2))))))))) - (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that) - (clear-bitmap/draw/bytes bm1 bdc bytes1 this color) - (clear-bitmap/draw/bytes bm2 bdc bytes2 that color) - (equal? bytes1 bytes2)) - - (define/private (clear-bitmap/draw/bytes bm bdc bytes obj color) + (define/private (draw-into bm bdc bytes obj) (send bdc set-bitmap bm) - (send bdc set-pen "black" 1 'transparent) - (send bdc set-brush color 'solid) - (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send bdc clear) (render-image obj bdc 0 0) (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes)) From 0590579daa3c0cfaf4302c6006585596f61980d2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Nov 2010 09:03:06 -0600 Subject: [PATCH 391/462] get two more 2htdp/image test cases to pass original commit: bf62d4b6d6e1968ddaf3adc835c4f70d7321228a --- collects/mrlib/image-core.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index b9b0057f..e9d4684d 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1014,7 +1014,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [(pen? color) (pen->pen-obj/cache color)] [else - (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid)])] + (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] [(solid) (send the-pen-list find-or-create-pen "black" 1 'transparent)])) From 0d9d00cb1cdcdc13320d7e8b00ec4c7e4e40d9bd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 16:57:44 -0700 Subject: [PATCH 392/462] cocoa: finally found the documented API to enable GUI mode original commit: ab070b205ea20b76b76dea5e027d2a35e7de6c73 --- collects/mred/private/wx/cocoa/finfo.rkt | 2 -- collects/mred/private/wx/cocoa/queue.rkt | 19 ++++++++++--------- collects/mred/private/wx/cocoa/types.rkt | 4 +++- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index dad503cb..300386ef 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -65,8 +65,6 @@ (define _FSRef _pointer) ; 80 bytes -(define _OSStatus _sint32) - (define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus)) (define-coreserv FSGetCatalogInfo diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 651d0eea..d6ca67c5 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -68,15 +68,16 @@ ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive ;; keyboard events. -;; This technique is not sanctioned by Apple --- I found the code in SDL. -(define-cstruct _CPSProcessSerNum ([lo _uint32] [hi _uint32])) -(define-appserv CPSGetCurrentProcess (_fun _CPSProcessSerNum-pointer -> _int) - #:fail (lambda () (lambda args 1))) -(define-appserv CPSEnableForegroundOperation (_fun _CPSProcessSerNum-pointer _int _int _int _int -> _int) - #:fail (lambda () #f)) -(let ([psn (make-CPSProcessSerNum 0 0)]) - (when (zero? (CPSGetCurrentProcess psn)) - (void (CPSEnableForegroundOperation psn #x03 #x3C #x2C #x1103)))) +(define-cstruct _ProcessSerialNumber + ([highLongOfPSN _ulong] + [lowLongOfPSN _ulong])) +(define kCurrentProcess 2) +(define kProcessTransformToForegroundApplication 1) +(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer + _uint32 + -> _OSStatus)) +(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) + kProcessTransformToForegroundApplication)) (define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (tellv app setDelegate: app-delegate) diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index 5e577c95..665aeae1 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -5,7 +5,7 @@ "utils.rkt") (provide - (protect-out _NSInteger _NSUInteger + (protect-out _NSInteger _NSUInteger _OSStatus _CGFloat _NSPoint _NSPoint-pointer (struct-out NSPoint) _NSSize _NSSize-pointer (struct-out NSSize) @@ -18,6 +18,8 @@ (define _NSInteger _long) (define _NSUInteger _ulong) +(define _OSStatus _sint32) + (define 64-bit? (= (ctype-sizeof _long) 8)) (define _CGFloat (make-ctype (if 64-bit? _double _float) From 1779a3853febd21e985c3a79a811967f346a1be1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 06:57:58 -0700 Subject: [PATCH 393/462] add 'close-button style to dialog%; fix cocoa default frame placement original commit: 820e832853058ee2063599ea9ab2bc8cfc23676f --- collects/framework/splash.rkt | 2 +- collects/mred/private/mrtop.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 10 ++++++---- collects/mred/private/wx/cocoa/procs.rkt | 11 ++++++++--- collects/mred/private/wx/cocoa/window.rkt | 4 +++- collects/mred/private/wxtop.rkt | 2 +- collects/scribblings/gui/dialog-class.scrbl | 7 ++++++- 7 files changed, 26 insertions(+), 12 deletions(-) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 9bb519ec..3edea6e3 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -286,7 +286,7 @@ (define/augment (on-close) (when quit-on-close? (exit))) - (super-new))) + (super-new [style '(close-button)]))) (define splash-canvas% (class canvas% diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index c107cfb1..a290834d 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -237,7 +237,7 @@ (check-label-string cwho label) (check-top-level-parent/false cwho parent) (for-each (lambda (x) (check-dimension cwho x)) (list width height x y)) - (check-style cwho #f '(no-caption resize-border no-sheet) style))) + (check-style cwho #f '(no-caption resize-border no-sheet close-button) style))) (rename [super-on-subwindow-char on-subwindow-char]) (private-field [wx #f]) (override diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 58ec5565..79e5c6a3 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -167,7 +167,9 @@ NSTitledWindowMask (if is-sheet? NSUtilityWindowMask 0) (if is-dialog? - 0 + (if (memq 'close-button style) + NSClosableWindowMask + 0) (bitwise-ior NSClosableWindowMask NSMiniaturizableWindowMask @@ -190,7 +192,7 @@ (tellv tb setVisible: #:type _BOOL #f) (tellv tb release)))) - (move -11111 (if (= y -11111) 0 y)) + (internal-move -11111 (if (= y -11111) 0 y)) (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) @@ -415,7 +417,7 @@ (define/override (set-size x y w h) (unless (and (= x -1) (= y -1)) - (move x y)) + (internal-move x y)) (let ([f (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect @@ -436,7 +438,7 @@ (NSSize-height (NSRect-size f))))) (make-NSSize w h)) display: #:type _BOOL #t))) - (define/override (move x y) + (define/override (internal-move x y) (let ([x (if (= x -11111) (get-x) x)] [y (if (= y -11111) (get-y) y)]) (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 77866d04..a6caa393 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -91,10 +91,15 @@ (define (check-for-break) #f) (define (display-origin xb yb all?) - (set-box! xb 0) (if all? - (set-box! yb 0) - (set-box! yb (get-menu-bar-height)))) + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (tell #:type _NSRect screen visibleFrame)]) + (set-box! xb (->long (NSPoint-x (NSRect-origin f))))))) + (set-box! xb 0)) + (set-box! yb (get-menu-bar-height))) + (define (display-size xb yb all?) (atomically (with-autorelease diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index a76e56fe..a23a7a72 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,8 +520,10 @@ (tellv cocoa setNeedsDisplay: #:type _BOOL #t) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (make-NSSize w h))))) - (define/public (move x y) + (define/public (internal-move x y) (set-size x y (get-width) (get-height))) + (define/public (move x y) + (internal-move x y)) (define accept-drag? #f) (define accept-parent-drag? #f) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index a0858c48..c1fd3e71 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -90,7 +90,7 @@ [panel #f] [use-default-position? (and (= -11111 (list-ref args 2)) - (= -11111 (list-ref args (if dlg? 3 1))))] + (= -11111 (list-ref args (if dlg? 3 1))))] [enabled? #t] [focus #f] diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 98f5e55d..15df4329 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -16,7 +16,9 @@ A dialog is a top-level window that is @defterm{modal}: while the [height (or/c (integer-in 0 10000) false/c) #f] [x (or/c (integer-in 0 10000) false/c) #f] [y (or/c (integer-in 0 10000) false/c) #f] - [style (listof (one-of/c 'no-caption 'resize-border 'no-sheet)) null] + [style (listof (one-of/c 'no-caption 'resize-border + 'no-sheet 'close-button)) + null] [enabled any/c #t] [border (integer-in 0 1000) 0] [spacing (integer-in 0 1000) 0] @@ -68,6 +70,9 @@ The @scheme[style] flags adjust the appearance of the dialog on some @item{@scheme['no-sheet] --- uses a movable window for the dialog, even if a parent window is provided (Mac OS X)} + @item{@scheme['close-button] --- include a close button in the + dialog's title bar, which would not normally be included (Mac OS X)} + ] Even if the dialog is not shown, a few notification events may be From 4723df4a890372da1a072e03c60f368a021bbbb0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 08:02:33 -0700 Subject: [PATCH 394/462] fix some racket/gui tests and fix cocoa frame centering original commit: 347869fc9e90560493f39654afd7037be7dac690 --- collects/mred/private/wx/cocoa/frame.rkt | 12 +++++------ collects/tests/gracket/windowing.rktl | 27 ++++++++++-------------- 2 files changed, 17 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 79e5c6a3..81972157 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -451,15 +451,15 @@ #:type _NSRect (make-NSRect (make-NSPoint (if (or (eq? dir 'both) (eq? dir 'horizontal)) - (/ (- (NSSize-width (NSRect-size s)) - (NSSize-width (NSRect-size f))) - 2) + (quotient (- (NSSize-width (NSRect-size s)) + (NSSize-width (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f))) (if (or (eq? dir 'both) (eq? dir 'vertical)) - (/ (- (NSSize-height (NSRect-size s)) - (NSSize-height (NSRect-size f))) - 2) + (quotient (- (NSSize-height (NSRect-size s)) + (NSSize-height (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f)))) (NSRect-size f)) display: #:type _BOOL #t))) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 52f0f245..34e479a4 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -66,7 +66,7 @@ (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h)))) (stv f refresh)) -(define (area-tests f sw? sh? no-stretch?) +(define (area-tests f sw? sh? no-stretch? use-client-size?) (printf "Area ~a\n" f) (let ([x (send f min-width)] [y (send f min-height)]) @@ -75,7 +75,9 @@ (stv (send f get-top-level-window) reflow-container) (pause) ; to make sure size has taken effect (let-values ([(w h) (if no-stretch? - (send f get-size) + (if use-client-size? + (send f get-client-size) + (send f get-size)) (values 0 0))]) (printf "Size ~a x ~a\n" w h) (when no-stretch? @@ -95,7 +97,7 @@ (stv f min-height y))) (define (containee-tests f sw? sh? m) - (area-tests f sw? sh? #f) + (area-tests f sw? sh? #f #f) (printf "Containee ~a\n" f) (st m f horiz-margin) (st m f vert-margin) @@ -166,7 +168,7 @@ (st my-l b get-plain-label) (stv b set-label &-l))) -(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)]) +(let ([f (make-object frame% "Yes & No" #f 150 151 70 21)]) (let ([init-tests (lambda (hidden?) (st "Yes & No" f get-label) @@ -177,15 +179,8 @@ (stv f set-label "Yes & No") (st #f f get-parent) (st f f get-top-level-window) - (case (system-type 'os) - [(unix) - (st 21 f get-x) - (if hidden? - (st 43 f get-y) - (st 22 f get-y))] - [else - (st 20 f get-x) - (st 21 f get-y)]) + (st 70 f get-x) + (st 21 f get-y) (st 150 f get-width) (st 151 f get-height) (stvals (list (send f get-width) (send f get-height)) f get-size) @@ -218,7 +213,7 @@ [container-tests (lambda () (printf "Container\n") - (area-tests f #t #t #t) + (area-tests f #t #t #t #t) (let-values ([(x y) (send f container-size null)]) (st x f min-width) (st y f min-height)) @@ -263,7 +258,7 @@ (stv f iconize #t) (pause) (pause) - (st #t f is-iconized?) ; NB: test will fail on MacOS + (st #t f is-iconized?) (stv f show #t) (pause) (st #f f is-iconized?) @@ -1010,7 +1005,7 @@ (test-controls panel frame) (if win? ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0) - (area-tests panel #t #t #f)) + (area-tests panel #t #t #f #f)) (when (is-a? panel panel%) (st #t panel get-orientation (is-a? panel horizontal-panel%))) (container-tests panel win?) From 2fdd64b4572b1216120af8bc09bedbfff49ffd00 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 08:41:50 -0700 Subject: [PATCH 395/462] cocoa: don't treat dead-key events as normal character events but more work is still needed for multi-key input original commit: df9c4c8c6906de97b919fa5f56c32a84a1b58afd --- collects/mred/private/wx/cocoa/window.rkt | 27 ++++++++++++++++------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index a23a7a72..5e5fd3ba 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -78,6 +78,7 @@ (import-protocol NSTextInput) (define current-insert-text (make-parameter #f)) +(define current-set-mark (make-parameter #f)) (define NSDragOperationCopy 1) @@ -169,6 +170,9 @@ [-a _NSRange (markedRange) (make-NSRange 0 0)] [-a _NSRange (selectedRange) (make-NSRange 0 0)] [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + ;; We interpreter a call to `setMarkedText:' as meaning that the + ;; key is a dead key for composing some other character. + (let ([m (current-set-mark)]) (when m (set-box! m #t))) (void)] [-a _id (validAttributesForMarkedText) #f] [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] @@ -213,7 +217,8 @@ (let ([wx (->wx wxb)]) (and wx - (let ([inserted-text (box #f)]) + (let ([inserted-text (box #f)] + [set-mark (box #f)]) (unless wheel? ;; Calling `interpretKeyEvents:' allows key combinations to be ;; handled, such as option-e followed by e to produce é. The @@ -222,16 +227,22 @@ ;; give us back the text in the parameter. For now, we ignore the ;; text and handle the event as usual, though probably we should ;; be doing something with it. - (parameterize ([current-insert-text inserted-text]) - (tellv self interpretKeyEvents: (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event - count: #:type _NSUInteger 1)))) + (parameterize ([current-insert-text inserted-text] + [current-set-mark set-mark]) + (let ([array (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)]) + (tellv self interpretKeyEvents: array) + (tellv array release)))) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (if wheel? - #f - (tell #:type _NSString event characters))] + [str (cond + [wheel? #f] + [(unbox set-mark) ""] ; => dead key for composing characters + [(unbox inserted-text)] + [else + (tell #:type _NSString event characters)])] [control? (bit? modifiers NSControlKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)] [delta-y (and wheel? From e0622ddb4f09bce70e2d5289edb547a21ade2df9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:38:28 -0700 Subject: [PATCH 396/462] cocoa: handle multi-key character input original commit: e0bcec082500e81a86ea2d307c371df53af4dc8c --- collects/mred/private/wx/cocoa/window.rkt | 183 ++++++++++++++-------- 1 file changed, 119 insertions(+), 64 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5e5fd3ba..11ae6cda 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -82,6 +82,16 @@ (define NSDragOperationCopy 1) +(import-class NSAttributedString) +(define _NSStringOrAttributed + (make-ctype _id + (lambda (v) + (cast v _NSString _id)) + (lambda (v) + (if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class)) + (tell #:type _NSString v string) + (cast v _id _NSString))))) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -152,7 +162,7 @@ [-a _void (keyUp: [_id event]) (unless (do-key-event wxb event self #f #f) (super-tell #:type _void keyUp: event))] - [-a _void (insertText: [_NSString str]) + [-a _void (insertText: [_NSStringOrAttributed str]) (let ([cit (current-insert-text)]) (if cit (set-box! cit str) @@ -163,24 +173,47 @@ (send wx key-event-as-string str)))))))] ;; for NSTextInput: - [-a _BOOL (hasMarkedText) #f] + [-a _BOOL (hasMarkedText) (get-saved-marked wxb)] [-a _id (validAttributesForMarkedText) (tell NSArray array)] - [-a _void (unmarkText) (void)] - [-a _NSRange (markedRange) (make-NSRange 0 0)] + [-a _void (unmarkText) + (set-saved-marked! wxb #f)] + [-a _NSRange (markedRange) + (let ([saved-marked (get-saved-marked wxb)]) + (make-NSRange 0 (if saved-marked 0 (length saved-marked))))] [-a _NSRange (selectedRange) (make-NSRange 0 0)] - [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange]) ;; We interpreter a call to `setMarkedText:' as meaning that the ;; key is a dead key for composing some other character. (let ([m (current-set-mark)]) (when m (set-box! m #t))) + ;; At the same time, we need to remember the text: + (set-saved-marked! wxb (range-substring aString selRange)) (void)] [-a _id (validAttributesForMarkedText) #f] - [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] + [-a _id (attributedSubstringFromRange: [_NSRange theRange]) + (let ([saved-marked (get-saved-marked wxb)]) + (and saved-marked + (let ([s (tell (tell NSAttributedString alloc) + initWithString: #:type _NSString + (range-substring saved-marked theRange))]) + (tellv s autorelease) + s)))] + [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] [-a _NSInteger (conversationIdentifier) 0] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] - [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) - (make-NSSize 0 0))] + [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) + ;; This location is used to place a window for multi-character + ;; input, such as when typing Chinese with Pinyin + (let ([f (tell #:type _NSRect self frame)] + [pt (tell #:type _NSPoint (tell self window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint self + convertPoint: #:type _NSPoint + (make-NSPoint 0 0) + toView: #f))]) + (make-NSRect pt (NSRect-size f)))] ;; Dragging: [-a _int (draggingEntered: [_id info]) @@ -200,6 +233,18 @@ (lambda () (send wx do-on-drop-file s))))))))))) #t]) +(define (set-saved-marked! wxb str) + (let ([wx (->wx wxb)]) + (when wx + (send wx set-saved-marked str)))) +(define (get-saved-marked wxb) + (let ([wx (->wx wxb)]) + (and wx + (send wx get-saved-marked)))) +(define (range-substring s range) + (let ([start (min (max 0 (NSRange-location range)) (string-length s))]) + (substring s start (max (min start (NSRange-length range)) (string-length s))))) + (define-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -246,61 +291,67 @@ [control? (bit? modifiers NSControlKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)] [delta-y (and wheel? - (tell #:type _CGFloat event deltaY))]) - (let-values ([(x y) (send wx window-point-to-view pos)]) - (let ([k (new key-event% - [key-code (if wheel? - (if (positive? delta-y) - 'wheel-up - 'wheel-down) - (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1F) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c)))))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down control?] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down option?] - [x (->long x)] - [y (->long y)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (unless wheel? - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (when (and (or (and option? - special-option-key?) - (and control? - (equal? (send k get-key-code) #\u00))) - (send k get-other-altgr-key-code)) - ;; swap altenate with main - (let ([other (send k get-other-altgr-key-code)]) - (send k set-other-altgr-key-code (send k get-key-code)) - (send k set-key-code other))) - (unless 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 definitely-wants-event? k) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-char/sync k))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))))))) + (tell #:type _CGFloat event deltaY))] + [codes (cond + [wheel? (if (positive? delta-y) + '(wheel-up) + '(wheel-down))] + [(map-key-code (tell #:type _ushort event keyCode)) + => list] + [(string=? "" str) '(#\nul)] + [(and (= 1 (string-length str)) + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1F) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0))))))) + => list] + [else str])]) + (for/fold ([result #f]) ([one-code codes]) + (or + ;; Handle one key event + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code one-code] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down control?] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down option?] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and (or (and option? + special-option-key?) + (and control? + (equal? (send k get-key-code) #\u00))) + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) + (unless 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 definitely-wants-event? k) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-char/sync k))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t)))) + result))))))) (define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) (let ([wx (->wx wxb)]) @@ -725,8 +776,12 @@ (define/public (can-be-responder?) #t) (define/public (on-color-change) - (send parent on-color-change)))) + (send parent on-color-change)) + ;; For multi-key character composition: + (define saved-marked #f) + (define/public (set-saved-marked v) (set! saved-marked v)) + (define/public (get-saved-marked) saved-marked))) ;; ---------------------------------------- From 0120b59ea51f49aaba2ea82abb5260e3504f2694 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:52:15 -0700 Subject: [PATCH 397/462] fix `draw-bitmap-section-smooth' method of bitmap-dc<%> original commit: 8e8844641c63767ce0df4428051cf086ffa91e6e --- collects/tests/gracket/dc.rktl | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 5e7d0f6f..afce8bc4 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -194,6 +194,27 @@ #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0"))) (test #t 'same-bits (equal? bs bs2))) +;; ---------------------------------------- +;; Test draw-bitmap-section-smooth + +(let* ([bm (make-bitmap 100 100)] + [dc (make-object bitmap-dc% bm)] + [bm2 (make-bitmap 70 70)] + [dc2 (make-object bitmap-dc% bm2)] + [bm3 (make-bitmap 70 70)] + [dc3 (make-object bitmap-dc% bm3)]) + (send dc draw-ellipse 0 0 100 100) + (send dc2 draw-bitmap-section-smooth bm + 10 10 50 50 + 0 0 100 100) + (send dc3 scale 0.5 0.5) + (send dc3 draw-bitmap bm 20 20) + (let ([s2 (make-bytes (* 4 70 70))] + [s3 (make-bytes (* 4 70 70))]) + (send bm2 get-argb-pixels 0 0 70 70 s2) + (send bm3 get-argb-pixels 0 0 70 70 s3) + (test #t 'same-scaled (equal? s2 s3)))) + ;; ---------------------------------------- (report-errs) From 99c829cd5b72ea3700941ed62ed5043210e16e7e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 08:10:31 -0700 Subject: [PATCH 398/462] win32: frame size and iconize fixes original commit: 1f61bbdc513ea7f07ae764cd0a6ae640e4e19479 --- collects/mred/private/wx/win32/const.rkt | 2 +- collects/mred/private/wx/win32/dialog.rkt | 6 ++++-- collects/mred/private/wx/win32/frame.rkt | 14 +++++++++----- collects/tests/gracket/windowing.rktl | 14 +++++++++++--- 4 files changed, 25 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 6f8b4cb8..a72df087 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -400,7 +400,7 @@ (define BS_FLAT #x00008000) (define BS_RIGHTBUTTON BS_LEFTTEXT) -(define CW_USEDEFAULT #x80000000) +(define CW_USEDEFAULT (- #x80000000)) ; minus sign => int instead of uint (define WS_EX_LAYERED #x00080000) (define WS_EX_TRANSPARENT #x00000020) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index c249f2f9..18ed2593 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -34,7 +34,7 @@ (class (dialog-mixin frame%) (super-new) - (define/override (create-frame parent label w h style) + (define/override (create-frame parent label x y w h style) (let ([hwnd (CreateDialogIndirectParamW hInstance (make-DLGTEMPLATE @@ -46,7 +46,9 @@ dialog-proc 0)]) (SetWindowTextW hwnd label) - (MoveWindow hwnd 0 0 w h #t) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (MoveWindow hwnd x y w h #t)) hwnd)) (define/override (is-dialog?) #t))) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 058d5caa..4bbfcddf 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -108,7 +108,7 @@ pre-on-char pre-on-event reset-cursor-in-child) - (define/public (create-frame parent label w h style) + (define/public (create-frame parent label x y w h style) (CreateWindowExW (if (memq 'float style) (bitwise-ior WS_EX_TOOLWINDOW (if (memq 'no-caption style) @@ -131,7 +131,9 @@ 0 (bitwise-ior WS_CAPTION WS_MINIMIZEBOX))) - 0 0 w h + (if (= x -11111) CW_USEDEFAULT x) + (if (= y -11111) CW_USEDEFAULT y) + w h #f #f hInstance @@ -146,7 +148,7 @@ (define max-height #f) (super-new [parent #f] - [hwnd (create-frame parent label w h style)] + [hwnd (create-frame parent label x y w h style)] [style (cons 'deleted style)]) (define hwnd (get-hwnd)) @@ -185,7 +187,9 @@ (set! hidden-zoomed? (is-maximized?))) (super direct-show on? (if hidden-zoomed? SW_SHOWMAXIMIZED - SW_SHOW))) + SW_SHOW)) + (when (and on? (iconized?)) + (ShowWindow hwnd SW_RESTORE))) (define/public (destroy) (direct-show #f)) @@ -393,7 +397,7 @@ (define/public (iconize on?) (when (is-shown?) - (when (or on? (not (iconized?))) + (unless (eq? (and on? #t) (iconized?)) (ShowWindow hwnd (if on? SW_MINIMIZE SW_RESTORE))))) (define/private (get-placement) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 34e479a4..b90260e0 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -259,6 +259,14 @@ (pause) (pause) (st #t f is-iconized?) + (stv f iconize #f) + (pause) + (pause) + (st #f f is-iconized?) + (stv f iconize #t) + (pause) + (pause) + (st #t f is-iconized?) (stv f show #t) (pause) (st #f f is-iconized?) @@ -277,16 +285,16 @@ (st 151 f get-height) (printf "Resize\n") - (stv f resize 56 57) + (stv f resize 156 57) (pause) (FAILS (st 34 f get-x)) (FAILS (st 37 f get-y)) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (stv f center) (pause) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (client->screen-tests) From 7789fcd82784d1eca471da9fbd2651a667b635bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 08:30:50 -0700 Subject: [PATCH 399/462] gtk & cocoa: frame iconize repairs In the "windowing.rktl" tests, for Gtk there are still race conditions between the program and the window manager. But for the first time ever, all platforms can pass the "windowing.rktl" test. original commit: 7da127227a3a493214b0878cd26bff6b51631115 --- collects/mred/private/wx/cocoa/frame.rkt | 4 +++- collects/mred/private/wx/gtk/frame.rkt | 2 ++ collects/tests/gracket/windowing.rktl | 24 ++++++++++++++++-------- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 81972157..eb2053c7 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -520,7 +520,9 @@ (define/public (iconized?) (tell #:type _BOOL cocoa isMiniaturized)) (define/public (iconize on?) - (tellv cocoa miniaturize: cocoa)) + (if on? + (tellv cocoa miniaturize: cocoa) + (tellv cocoa deminiaturize: cocoa))) (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c1c43315..994ab5f2 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -180,6 +180,7 @@ (connect-delete gtk) (connect-configure gtk) (connect-focus gtk) + (connect-window-state gtk) (define saved-title (or label "")) (define is-modified? #f) @@ -311,6 +312,7 @@ (hash-set! all-frames this #t) (hash-remove! all-frames this)) (super direct-show on?) + (when on? (gtk_window_deiconify gtk)) (register-frame-shown this on?)) (define/public (destroy) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index b90260e0..1f36d1d9 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -30,6 +30,17 @@ (thread (lambda () (sleep 0.01) (semaphore-post s))) (test s 'yield (yield s)))) +(define (iconize-pause) + (if (eq? 'unix (system-type)) + ;; iconization might take a while + ;; for the window manager to report back + (begin + (pause) + (when (regexp-match? #rx"darwin" (path->string (system-library-subpath))) + (sleep 0.75)) + (pause)) + (pause))) + (let ([s (make-semaphore 1)]) (test s 'yield-wrapped (yield s))) (let ([s (make-semaphore 1)]) @@ -256,21 +267,18 @@ (printf "Iconize\n") (stv f iconize #t) - (pause) - (pause) + (iconize-pause) (st #t f is-iconized?) (stv f iconize #f) - (pause) - (pause) + (iconize-pause) (st #f f is-iconized?) (stv f iconize #t) - (pause) - (pause) + (iconize-pause) (st #t f is-iconized?) (stv f show #t) - (pause) + (iconize-pause) (st #f f is-iconized?) - + (stv f maximize #t) (pause) (stv f maximize #f) From f56c9fbe30f3ba6637dce8babb69135de6e0187e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 10:25:37 -0700 Subject: [PATCH 400/462] add pdf-dc%; make slideshow/pict depend on racket/draw, not racket/gui original commit: 2edadd611303978255f6ff53efa5b691a0f7f0a5 --- collects/mred/mred-sig.rkt | 1 + collects/tests/gracket/draw.rkt | 24 ++++++++++--------- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 3 +++ 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 1f8aa217..0b5efef1 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -143,6 +143,7 @@ open-output-text-editor pane% panel% pasteboard% +pdf-dc% pen% pen-list% play-sound diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 38922349..882d0cb9 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -263,7 +263,7 @@ [on-paint (case-lambda [() (time (on-paint #f))] - [(ps?) + [(kind) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] [pen1s (make-object pen% "BLACK" 1 'solid)] @@ -811,7 +811,7 @@ (send dc draw-rectangle 180 205 20 20) (send dc set-brush brushs)))) - (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc)))) + (when (and pixel-copy? last? (not (or kind (eq? dc can-dc)))) (let* ([x 100] [y 170] [x2 245] [y2 188] @@ -941,7 +941,7 @@ (send dc draw-rectangle 187 310 20 20) (send dc set-pen p))) - (when (and last? (not (or ps? (eq? dc can-dc))) + (when (and last? (not (or kind (eq? dc can-dc))) (send mem-dc get-bitmap)) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) @@ -950,10 +950,11 @@ (send (get-dc) set-scale 1 1) (send (get-dc) set-origin 0 0) - (let ([dc (if ps? - (let ([dc (if (eq? ps? 'print) - (make-object printer-dc%) - (make-object post-script-dc%))]) + (let ([dc (if kind + (let ([dc (case kind + [(print) (make-object printer-dc%)] + [(ps) (make-object post-script-dc%)] + [(pdf) (make-object pdf-dc%)])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin @@ -1112,7 +1113,7 @@ (let-values ([(w h) (send dc get-size)]) (unless (cond - [ps? #t] + [kind #t] [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) @@ -1143,10 +1144,10 @@ '(horizontal)) (make-object button% "PS" hp (lambda (self event) - (send canvas on-paint #t))) - (make-object button% "Print" hp + (send canvas on-paint 'ps))) + (make-object button% "PDF" hp (lambda (self event) - (send canvas on-paint 'print))) + (send canvas on-paint 'pdf))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp (lambda (self event) (send canvas set-scale @@ -1243,6 +1244,7 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print))) (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) (when c (send (current-ps-setup) copy-from c))))) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 36c1d1ef..4c1688c8 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -112,6 +112,9 @@ that it is installed as a clipping region. The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + Editor Changes -------------- From 86e4eed1128b08de7e4dd1909d80ce7b3f8180dd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:20:15 -0700 Subject: [PATCH 401/462] centralize glib loading as used by racket/draw and Gtk racket/gui original commit: 5aff70029abb6bd804c156b412f1a2ab70ebfa23 --- collects/mred/private/wx/gtk/utils.rkt | 29 +++----------------------- 1 file changed, 3 insertions(+), 26 deletions(-) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 16d569ef..069e4d42 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -2,16 +2,17 @@ (require ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc + racket/draw/unsafe/glib (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") (provide define-mz + define-gobj + define-glib (protect-out define-gtk define-gdk - define-gobj - define-glib define-gdk_pixbuf g_object_ref @@ -56,27 +57,6 @@ (ffi-lib "libgdk_pixbuf-2.0-0") (ffi-lib "libgdk-win32-2.0-0")] [else (ffi-lib "libgdk-x11-2.0" '("0"))])) -(define gobj-lib - (case (system-type) - [(windows) - (ffi-lib "libgobject-2.0-0")] - [(unix) - (ffi-lib "libgobject-2.0" '("0"))] - [else gdk-lib])) -(define glib-lib - (case (system-type) - [(windows) - (ffi-lib "libglib-2.0-0")] - [(unix) - (ffi-lib "libglib-2.0" '("0"))] - [else gdk-lib])) -(define gmodule-lib - (case (system-type) - [(windows) - (ffi-lib "libgmodule-2.0-0")] - [(unix) - (ffi-lib "libgmodule-2.0" '("0"))] - [else gdk-lib])) (define gdk_pixbuf-lib (case (system-type) [(windows) @@ -91,9 +71,6 @@ [else (ffi-lib "libgtk-x11-2.0" '("0"))])) (define-ffi-definer define-gtk gtk-lib) -(define-ffi-definer define-gobj gobj-lib) -(define-ffi-definer define-glib glib-lib) -(define-ffi-definer define-gmodule gmodule-lib) (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) From f7594ac5c47cafae07de6bc8eaa56fc3350d194a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:55:32 -0700 Subject: [PATCH 402/462] cocoa & gtk: fix set-label with bitmap on message% Closes PR 11462 original commit: 04a4ad269fb446000bb463e793e6e8e16457499d --- collects/mred/private/mritem.rkt | 10 +++++++--- collects/mred/private/wx/cocoa/message.rkt | 6 +++++- collects/mred/private/wx/gtk/message.rkt | 11 ++++++++++- 3 files changed, 22 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 6d2a89f5..0302d72b 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -58,7 +58,7 @@ ;; for keyword use [font no-val]) (rename [super-set-label set-label]) - (private-field [label lbl][callback cb]) + (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)]) (override [get-label (lambda () label)] [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] @@ -69,8 +69,12 @@ (let ([l (if (string? l) (string->immutable-string l) l)]) - (send wx set-label l) - (set! label l))))]) + (when (or (and is-bitmap? + (l . is-a? . wx:bitmap%)) + (and (not is-bitmap?) + (string? l))) + (send wx set-label l) + (set! label l)))))]) (public [hidden-child? (lambda () #f)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 1a3896ef..bd9ef2a0 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -94,7 +94,11 @@ [no-show? (memq 'deleted style)]) (define/override (set-label label) - (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)) + (cond + [(string? label) + (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv (get-cocoa) setImage: (bitmap->image label))])) (define/override (gets-focus?) #f) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index fd47ac52..587f3291 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -2,6 +2,7 @@ (require racket/class ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "item.rkt" "utils.rkt" "types.rkt" @@ -21,6 +22,7 @@ (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) (define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) +(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -75,6 +77,13 @@ (set-auto-size) (define/override (set-label s) - (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) + (cond + [(string? s) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (gtk_image_set_from_pixbuf (get-gtk) pixbuf) + (release-pixbuf pixbuf)))])) (def/public-unimplemented get-font)) From 657512f5676c532a364f72fc54186168290de434 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 17:20:24 -0700 Subject: [PATCH 403/462] add `width' and `height' arguments to post-script-dc% and pdf-dc% and document the change that the PS bounding box is no longer inferred from drawing operations original commit: abcaa1775ca5aad50e87705100a1047bfc7b5e7c --- collects/tests/gracket/draw.rkt | 16 ++++++++++++++-- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 14 +++++++++++--- 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 882d0cb9..3d8158cb 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -953,8 +953,20 @@ (let ([dc (if kind (let ([dc (case kind [(print) (make-object printer-dc%)] - [(ps) (make-object post-script-dc%)] - [(pdf) (make-object pdf-dc%)])]) + [(ps pdf) + (let ([page? + (eq? 'yes (message-box + "Bounding Box" + "Use paper bounding box?" + #f + '(yes-no)))]) + (new (if (eq? kind 'ps) + post-script-dc% + pdf-dc%) + [width (* xscale DRAW-WIDTH)] + [height (* yscale DRAW-HEIGHT)] + [as-eps (not page?)] + [use-paper-bbox page?]))])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 4c1688c8..8e3b7069 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -95,6 +95,17 @@ backward-compatibile. Methods like `get-translation', `set-translation', `scale', etc. help hide the reundancy. +PostScript and PDF Drawing Contexts +----------------------------------- + +The dimensions for PostScript output are no longer inferred from the +drawing. Instead, the width and height must be supplied when the +`post-script-dc%' is created. + +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + + Other Drawing-Context Changes ----------------------------- @@ -112,9 +123,6 @@ that it is installed as a clipping region. The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). -The new `pdf-dc%' drawing context is like `post-script-dc%', but it -generates PDF output. - Editor Changes -------------- From cde87458e685945d6f0a5d19a1099a44b356e1ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 08:28:57 -0700 Subject: [PATCH 404/462] doc correction Closes PR 11465 original commit: 430d45b471aff9d3b09f21ed11aedae1b4067396 --- collects/scribblings/gui/editor-overview.scrbl | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 6558dc3a..f8cbcfcc 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -720,11 +720,10 @@ An editor is not tied to any particular thread or eventspace, except to the degree that it is displayed in a canvas (which has an eventspace). Concurrent access of an editor is always safe, in the sense that the editor will not become corrupted. However, because - editor access can trigger locks, and because lock-rejected operations - tend to fail silently, concurrent access can produce unexpected - results. + editor access can trigger locks, concurrent access can produce + contract failures or unexpected results. -Nevertheless, the editor supports certain concurrent patterns +An editor supports certain concurrent patterns reliably. One relevant pattern is updating an editor in one thread while the editor is displayed in a canvas that is managed by a different (handler) thread. To ensure that canvas refreshes are not From bc99d8ca8438a978583c84b4e90c10f07aef79f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 20:01:41 -0700 Subject: [PATCH 405/462] reorganize racket/gui docs and expand canvas-drawing overview original commit: 68391fe2ea94af688bcc8c5825fb92d66fc0784d --- collects/scribblings/gui/dynamic.scrbl | 20 ++- .../scribblings/gui/editor-overview.scrbl | 2 +- collects/scribblings/gui/gui.scrbl | 26 +++- collects/scribblings/gui/guide.scrbl | 21 ---- collects/scribblings/gui/win-overview.scrbl | 117 +++++++++++++++--- 5 files changed, 132 insertions(+), 54 deletions(-) diff --git a/collects/scribblings/gui/dynamic.scrbl b/collects/scribblings/gui/dynamic.scrbl index b0f35c3f..2e4e52f8 100644 --- a/collects/scribblings/gui/dynamic.scrbl +++ b/collects/scribblings/gui/dynamic.scrbl @@ -5,21 +5,17 @@ @title{Dynamic Loading} @defmodule[racket/gui/dynamic]{The @racketmodname[racket/gui/dynamic] -library provides functions for dynamically accessing the Racket -GUI toolbox, instead of directly requiring @racket[racket/gui] or -@racket[racket/gui/base].} +library provides functions for dynamically accessing the +@racketmodname[racket/gui/base] library, instead of directly requiring +@racketmodname[racket/gui] or @racketmodname[racket/gui/base].} @defproc[(gui-available?) boolean?]{ -Returns @racket[#t] if dynamic access to the GUI bindings are -available---that is, that the program is being run as a -GRacket-based application, as opposed to a pure -Racket-based application, and that GUI modules are attached -to the namespace in which @racket[racket/gui/dynamic] was -instantiated. - -This predicate can be used in code that optionally uses GUI elements -when they are available.} +Returns @racket[#t] if dynamic access to the GUI bindings is +available. The bindings are available if +@racketmodname[racket/gui/base] has been loaded, instantiated, and +attached to the namespace in which @racket[racket/gui/dynamic] was +instantiated.} @defproc[(gui-dynamic-require [sym symbol?]) any]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index f8cbcfcc..bc0c15bf 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -2,7 +2,7 @@ @(require scribble/bnf "common.ss") -@title[#:tag "editor-overview"]{Editor} +@title[#:tag "editor-overview"]{Editors} The editor toolbox provides a foundation for two common kinds of applications: diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 31cdac7a..fe6050f7 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -17,13 +17,35 @@ to the bindings of @racketmodname[racket/draw].} @racketmodname[racket] language and the @racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} +The @racketmodname[racket/draw] toolbox is roughly organized into two +parts: + +@itemize[ + + @item{The @deftech{windowing toolbox}, for implementing windows, + buttons, menus, text fields, and other controls.} + + @item{The @deftech{editor toolbox}, for developing traditional text + editors, editors that mix text and graphics, or free-form layout + editors (such as a word processor, HTML editor, or icon-based file + browser).} + +] + +Both parts of the toolbox rely extensively on the +@racketmodname[racket/draw] drawing library. @table-of-contents[] @;------------------------------------------------------------------------ -@include-section["guide.scrbl"] -@include-section["reference.scrbl"] +@include-section["win-overview.scrbl"] +@include-section["win-classes.scrbl"] +@include-section["win-funcs.scrbl"] +@include-section["editor-overview.scrbl"] +@include-section["editor-classes.scrbl"] +@include-section["editor-funcs.scrbl"] +@include-section["wxme.scrbl"] @include-section["prefs.scrbl"] @include-section["dynamic.scrbl"] diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index 3b4058e5..25d27029 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -3,27 +3,6 @@ @title[#:style '(toc reveal)]{Overview} -For documentation purposes, the graphics toolbox is organized into - two parts: - -@itemize[ - - @item{The @deftech{windowing toolbox}, for implementing form-filling - GUI programs (such as a database query window) using buttons, menus, - text fields, and events. The windowing toolbox is described in - @secref["windowing-overview"].} - - @item{The @deftech{editor toolbox}, for developing traditional text - editors, editors that mix text and graphics, or free-form layout - editors (such as a word processor, HTML editor, or icon-based file - browser). The editor toolbox is described in - @secref["editor-overview"].} - -] - -Simple GUI programs access only the windowing toolbox directly, while - large-scale applications tend to use the editor toolbox as well. - @local-table-of-contents[] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1b632b55..45ad0a0a 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -5,11 +5,19 @@ @title[#:tag "windowing-overview"]{Windowing} -The Racket windowing toolbox provides the basic building blocks of GUI +The windowing toolbox provides the basic building blocks of GUI programs, including frames (top-level windows), modal dialogs, menus, - buttons, check boxes, text fields, and radio buttons. The toolbox - provides these building blocks via built-in classes, such as the - @scheme[frame%] class: + buttons, check boxes, text fields, and radio buttons---all as + classes. + +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and +interfaces in Racket.} + +@section{Creating Windows} + +To create a new top-level window, instantiate the @scheme[frame%] + class: @schemeblock[ (code:comment @#,t{Make a frame by instantiating the @scheme[frame%] class}) @@ -21,7 +29,7 @@ The Racket windowing toolbox provides the basic building blocks of GUI The built-in classes provide various mechanisms for handling GUI events. For example, when instantiating the @scheme[button%] class, - the programmer supplies an event callback procedure to be invoked + supply an event callback procedure to be invoked when the user clicks the button. The following example program creates a frame with a text message and a button; when the user clicks the button, the message changes: @@ -46,18 +54,18 @@ The built-in classes provide various mechanisms for handling GUI ] Programmers never implement the GUI event loop directly. Instead, the - system automatically pulls each event from an internal queue and + windowing system automatically pulls each event from an internal queue and dispatches the event to an appropriate window. The dispatch invokes the window's callback procedure or calls one of the window's - methods. In the above program, the system automatically invokes the + methods. In the above program, the windowing system automatically invokes the button's callback procedure whenever the user clicks @onscreen{Click Me}. If a window receives multiple kinds of events, the events are dispatched to methods of the window's class instead of to a callback procedure. For example, a drawing canvas receives update events, - mouse events, keyboard events, and sizing events; to handle them, a - programmer must derive a new class from the built-in + mouse events, keyboard events, and sizing events; to handle them, + derive a new class from the built-in @scheme[canvas%] class and override the event-handling methods. The following expression extends the frame created above with a canvas that handles mouse and keyboard events: @@ -86,10 +94,10 @@ After running the above code, manually resize the frame to see the on-event]. While the canvas has the keyboard focus, typing on the keyboard invokes the canvas's @method[canvas<%> on-char] method. -The system dispatches GUI events sequentially; that is, after invoking - an event-handling callback or method, the system waits until the +The windowing system dispatches GUI events sequentially; that is, after invoking + an event-handling callback or method, the windowing system waits until the handler returns before dispatching the next event. To illustrate the - sequential nature of events, we extend the frame again, adding a + sequential nature of events, extend the frame again, adding a @onscreen{Pause} button: @schemeblock[ @@ -99,7 +107,7 @@ The system dispatches GUI events sequentially; that is, after invoking ] After the user clicks @onscreen{Pause}, the entire frame becomes - unresponsive for five seconds; the system cannot dispatch more events + unresponsive for five seconds; the windowing system cannot dispatch more events until the call to @scheme[sleep] returns. For more information about event dispatching, see @secref["eventspaceinfo"]. @@ -111,7 +119,7 @@ In addition to dispatching events, the GUI classes also handle the as a frame, arranges its children in a column, and a horizontal container arranges its children in a row. A container can be a child of another container; for example, to place two buttons side-by-side - in our frame, we create a horizontal panel for the new buttons: + in our frame, create a horizontal panel for the new buttons: @schemeblock[ (define panel (new horizontal-panel% [parent frame])) @@ -128,6 +136,49 @@ In addition to dispatching events, the GUI classes also handle the For more information about window layout and containers, see @secref["containeroverview"]. + +@section[#:tag "canvas-drawing"]{Drawing in Canvases} + +The content of a canvas is determined by its @method[canvas% on-paint] +method, where the default @method[canvas% on-paint] calls the +@racket[paint-callback] function that is supplied when the canvas is +created. The @method[canvas% on-paint] method receives no arguments +and uses the canvas's @method[canvas<%> get-dc] method to obtain a +@tech[#:doc '(lib "scribblings/draw/draw.scrbl")]{drawing context} +(DC) for drawing; the default @method[canvas% on-paint] method passes +the canvas and this DC on to the @racket[paint-callback] function. +Drawing operations of the @racket[racket/draw] toolbox on the DC are +reflected in the content of the canvas onscreen. + +For example, the following program creates a canvas +that displays large, friendly letters: + +@schemeblock[ +(define frame (new frame% + [label "Example"] + [width 300] + [height 300])) +(new canvas% [parent frame] + [paint-callback + (lambda (canvas dc) + (send dc #,(:: dc<%> set-scale) 3 3) + (send dc #,(:: dc<%> set-text-foreground) "blue") + (send dc #,(:: dc<%> draw-text) "Don't Panic!" 0 0))]) +(send frame #,(:: top-level-window<%> show) #t) +] + +The background color of a canvas can be set through the +@method[canvas<%> set-canvas-background] method. To make the canvas +transparent (so that it takes on its parent's color and texture as its +initial content), supply @racket['transparent] in the @racket[style] +argument when creating the canvas. + +See @secref["overview" #:doc '(lib "scribblings/draw/draw.scrbl")] in +@other-doc['(lib "scribblings/draw/draw.scrbl")] for an overview of +drawing with the @racket[racket/draw] library. For more advanced +information on canvas drawing, see @secref["animation"]. + + @section{Core Windowing Classes} The fundamental graphical element in the windowing toolbox is an @@ -328,7 +379,7 @@ The built-in container classes include horizontal panels (and panes), which align their children in a row, and vertical panels (and panes), which align their children in a column. By nesting horizontal and vertical containers, a programmer can achieve most any layout. For - example, we can construct a dialog with the following shape: + example, to construct a dialog with the shape @verbatim[#:indent 2]{ ------------------------------------------------------ @@ -654,10 +705,9 @@ Whenever the user moves the mouse, clicks or releases a mouse button, target window. A program can use the @method[window<%> focus] method to move the focus to a subwindow or to set the initial focus. - Under X, a @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] + A @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] event may be sent to a window other than the one with the keyboard - focus, because X generates wheel events based on the location of the - mouse pointer. + focus, depending on how the operating system handles wheel events. A key-press event may correspond to either an actual key press or an auto-key repeat. Multiple key-press events without intervening @@ -942,3 +992,34 @@ This expression installs an exception handler that prints an error handler during the call to @scheme[yield], an error message is printed before control returns to the event dispatcher within @scheme[yield]. + + +@section[#:tag "animation"]{Animation in Canvases} + +The content of a canvas is buffered, so if a canvas must be redrawn, +the @method[canvas% on-paint] method or @racket[paint-callback] function +usually does not need to be called again. To further reduce flicker, +while the @method[canvas% on-paint] method or @racket[paint-callback] function +is called, the windowing system avoids flushing the canvas-content +buffer to the screen. + +Canvas content can be updated at any time by drawing with the result +of the canvas's @method[canvas<%> get-dc] method, and drawing is +thread-safe. Changes to the canvas's content are flushed to the screen +periodically (not necessarily on an event-handling boundary), but the +@method[canvas<%> flush] method immediately flushes to the screen---as +long as flushing has not been suspended. The @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] methods suspend and +resume both automatic and explicit flushes, although on some +platforms, automatic flushes are forced in rare cases. + +For most animation purposes, @method[canvas<%> suspend-flush], +@method[canvas<%> resume-flush], and @method[canvas<%> flush] can be +used to avoid flicker and the need for an additional drawing buffer +for animations. During an animation, bracket the construction of each +animation frame with @method[canvas<%> suspend-flush] and +@method[canvas<%> resume-flush] to ensure that partially drawn frames +are not flushed to the screen. Use @method[canvas<%> flush] to ensure +that canvas content is flushed when it is ready if a @method[canvas<%> +suspend-flush] will soon follow, because the process of flushing to +the screen can be starved if flushing is frequently suspend. From ef1cdeae6ea91be386136d922ba311022498377c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 20:19:11 -0700 Subject: [PATCH 406/462] fix typo original commit: f88735ef20e1dfb8c1cb46984a2936f9bdfe2c12 --- collects/scribblings/gui/gui.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index fe6050f7..b51741fe 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -17,7 +17,7 @@ to the bindings of @racketmodname[racket/draw].} @racketmodname[racket] language and the @racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} -The @racketmodname[racket/draw] toolbox is roughly organized into two +The @racketmodname[racket/gui] toolbox is roughly organized into two parts: @itemize[ From 48abd21d7c80ed1d3c111970e7b92d82ecdb2261 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:46:36 -0700 Subject: [PATCH 407/462] cocoa: fix enable & disable of windows original commit: 262531e23121a4a11b5e683923a961712d003b10 --- collects/mred/private/wx/cocoa/canvas.rkt | 14 +++++++++++++- collects/mred/private/wx/cocoa/frame.rkt | 7 ++++++- collects/mred/private/wx/cocoa/item.rkt | 10 +++++----- collects/mred/private/wx/cocoa/panel.rkt | 8 +++++++- collects/mred/private/wx/cocoa/tab-panel.rkt | 16 +++++++++++++++- collects/mred/private/wx/cocoa/window.rkt | 16 ++++++++++++---- 6 files changed, 58 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 34f80512..551eed0d 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -234,6 +234,9 @@ make-graphics-context is-shown-to-root? is-shown-to-before-root? + is-enabled-to-root? + is-window-enabled? + block-mouse-events move get-x get-y on-size register-as-child @@ -608,6 +611,15 @@ (scroller-page scroller) 1)])) + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (let ([w (tell content-cocoa window)]) + (when (ptr-equal? content-cocoa (tell w firstResponder)) + (tellv w makeFirstResponder: #f))) + (block-mouse-events (not on?)) + (when is-combo? + (tellv content-cocoa setEnabled: #:type _BOOL on?)))) + (define/public (clear-combo-items) (tellv content-cocoa removeAllItems)) (define/public (append-combo-item str) @@ -698,7 +710,7 @@ (define/override (gets-focus?) wants-focus?) (define/override (can-be-responder?) - wants-focus?) + (and wants-focus? (is-enabled-to-root?))) (define/private (on-menu-click? e) ;; Called in Cocoa event-handling mode diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index eb2053c7..ffe008e4 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -141,7 +141,8 @@ get-eventspace pre-on-char pre-on-event get-x - on-new-child) + on-new-child + is-window-enabled?) (super-new [parent parent] [cocoa @@ -333,6 +334,10 @@ (when saved-child (send saved-child child-accept-drag on?))) + (define/override (enable-window on?) + (when saved-child + (send saved-child enable-window (and on? (is-window-enabled?))))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index e04a3751..2ff73fa1 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -29,16 +29,16 @@ (tellv cocoa setFont: sys-font))) (defclass item% window% - (inherit get-cocoa) + (inherit get-cocoa + is-window-enabled?) (init-field callback) (define/public (get-cocoa-control) (get-cocoa)) - (define/override (enable on?) - (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?)) - (define/override (is-window-enabled?) - (tell #:type _BOOL (get-cocoa-control) isEnabled)) + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?))) (define/override (gets-focus?) (tell #:type _BOOL (get-cocoa-control) canBecomeKeyView)) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 6d57fecc..85864672 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -19,7 +19,8 @@ (define (panel-mixin %) (class % - (inherit register-as-child on-new-child) + (inherit register-as-child on-new-child + is-window-enabled?) (define lbl-pos 'horizontal) (define children null) @@ -52,6 +53,11 @@ (define/override (children-accept-drag on?) (for ([child (in-list children)]) (send child child-accept-drag on?))) + + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (for ([child (in-list children)]) + (send child enable-window on?)))) (define/override (set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index d67e669e..6b11d595 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -23,6 +23,9 @@ (void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))) (define NSNoTabsNoBorder 6) +(define NSDefaultControlTint 0) +(define NSClearControlTint 7) + (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) @@ -44,7 +47,9 @@ x y w h style labels) - (inherit get-cocoa register-as-child) + (inherit get-cocoa register-as-child + is-window-enabled? + block-mouse-events) (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) @@ -154,6 +159,15 @@ (when control-cocoa (set-ivar! control-cocoa wxb (->wxb this))) + (define/override (enable-window on?) + (super enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (block-mouse-events (not on?)) + (tellv tabv-cocoa setControlTint: #:type _int + (if on? NSDefaultControlTint NSClearControlTint)) + (when control-cocoa + (tellv control-cocoa setEnabled: #:type _BOOL on?)))) + (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 11ae6cda..0c37a04e 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,7 +520,14 @@ (define/public (is-window-enabled?) enabled?) (define/public (enable on?) - (set! enabled? on?)) + (set! enabled? on?) + (enable-window on?)) + (define/public (enable-window on?) + (void)) + + (define block-all-mouse-events? #f) + (define/public (block-mouse-events block?) + (set! block-all-mouse-events? block?)) (define/private (get-frame) (let ([v (tell #:type _NSRect cocoa frame)]) @@ -621,7 +628,8 @@ (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))) (define/public (set-focus) - (when (gets-focus?) + (when (and (gets-focus?) + (is-enabled-to-root?)) (let ([w (tell cocoa window)]) (when w (tellv w makeFirstResponder: (get-cocoa-content)))))) @@ -664,7 +672,7 @@ (cond [(other-modal? this) #t] [(call-pre-on-event this e) #t] - [just-pre? #f] + [just-pre? block-all-mouse-events?] [else (when enabled? (on-event e)) #t])) (define/public (call-pre-on-event w e) @@ -773,7 +781,7 @@ (define/public (get-cursor-width-delta) 0) (define/public (gets-focus?) #f) - (define/public (can-be-responder?) #t) + (define/public (can-be-responder?) (is-enabled-to-root?)) (define/public (on-color-change) (send parent on-color-change)) From 15e6373fe4a99e7443981360196c01f3adfcb2a5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:52:01 -0700 Subject: [PATCH 408/462] cocoa: fix relabel of image checkbox original commit: f090e732fd8fb63f92dfb30391c9bd8d3910c281 --- collects/mred/private/wx/cocoa/button.rkt | 73 ++++++++++++----------- 1 file changed, 37 insertions(+), 36 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 94cf0f6a..1987e278 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -87,41 +87,42 @@ (NSSize-height (NSRect-size frame))))))) cocoa)) - (define cocoa (if (and button-type - (not (string? label)) - (send label ok?)) - ;; Check-box image: need an view to join a button and an image view: - ;; (Could we use the NSImageButtonCell from the radio-box implementation - ;; instead?) - (let* ([frame (tell #:type _NSRect button-cocoa frame)] - [new-width (+ (NSSize-width (NSRect-size frame)) - (send label get-width))] - [new-height (max (NSSize-height (NSRect-size frame)) - (send label get-height))]) - (let ([cocoa (as-objc-allocation - (tell (tell NSView alloc) - initWithFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize new-width - new-height))))] - [image-cocoa (as-objc-allocation - (tell (tell NSImageView alloc) init))]) - (tellv cocoa addSubview: button-cocoa) - (tellv cocoa addSubview: image-cocoa) - (tellv image-cocoa setImage: (bitmap->image label)) - (tellv image-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) - (quotient (- new-height - (send label get-height)) - 2)) - (make-NSSize (send label get-width) - (send label get-height)))) - (tellv button-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint 0 0) - (make-NSSize new-width new-height))) - (set-ivar! button-cocoa wxb (->wxb this)) - cocoa)) - button-cocoa)) + (define-values (cocoa image-cocoa) + (if (and button-type + (not (string? label)) + (send label ok?)) + ;; Check-box image: need an view to join a button and an image view: + ;; (Could we use the NSImageButtonCell from the radio-box implementation + ;; instead?) + (let* ([frame (tell #:type _NSRect button-cocoa frame)] + [new-width (+ (NSSize-width (NSRect-size frame)) + (send label get-width))] + [new-height (max (NSSize-height (NSRect-size frame)) + (send label get-height))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] + [image-cocoa (as-objc-allocation + (tell (tell NSImageView alloc) init))]) + (tellv cocoa addSubview: button-cocoa) + (tellv cocoa addSubview: image-cocoa) + (tellv image-cocoa setImage: (bitmap->image label)) + (tellv image-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) + (quotient (- new-height + (send label get-height)) + 2)) + (make-NSSize (send label get-width) + (send label get-height)))) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize new-width new-height))) + (set-ivar! button-cocoa wxb (->wxb this)) + (values cocoa image-cocoa))) + (values button-cocoa #f))) (define we (make-will-executor)) @@ -146,7 +147,7 @@ [(string? label) (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] [else - (tellv cocoa setImage: (bitmap->image label))])) + (tellv (or image-cocoa cocoa) setImage: (bitmap->image label))])) (define callback cb) (define/public (clicked) From e73027e3ad86649366cfacdc3d9236d6b4503c15 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 10:41:59 -0700 Subject: [PATCH 409/462] cocoa: fix problem with tab panel original commit: d37cc7b3ec702c9d89a6fc3a18f65c873fdd2c11 --- collects/mred/private/wx/cocoa/tab-panel.rkt | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 6b11d595..5b5b2205 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -29,6 +29,17 @@ (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) +(define NSOrderedAscending -1) +(define NSOrderedSame 0) +(define NSOrderedDescending 1) +(define (order-content-first a b data) + (cond + [(ptr-equal? a data) NSOrderedDescending] + [(ptr-equal? b data) NSOrderedAscending] + [else NSOrderedSame])) +(define order_content_first (function-ptr order-content-first + (_fun #:atomic? #t _id _id _id -> _int))) + (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] @@ -131,7 +142,11 @@ (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) (tellv tabv-cocoa addTabViewItem: item) - (set! item-cocoas (append item-cocoas (list item))))) + (set! item-cocoas (append item-cocoas (list item))) + ;; Sometimes the sub-view for the tab buttons gets put in front + ;; of the content view, so fix the order: + (tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first + context: #:type _pointer content-cocoa))) (define/public (delete i) (let ([item-cocoa (list-ref item-cocoas i)]) From 23ce6127162864478262b6fcba2ab6d40556e203 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 09:21:16 -0700 Subject: [PATCH 410/462] cocoa: fix removal of menu shortcut Closes PR 11463 original commit: 2282cae59ab233d9f054bb87d1eefb72f82a74ac --- collects/mred/private/wx/cocoa/menu-item.rkt | 37 ++++++++++---------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 6f26da24..bea50304 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -80,21 +80,22 @@ (define (set-menu-item-shortcut item label) (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods))))) + (if shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)) + (tellv item setKeyEquivalent: #:type _NSString "")))) From 653df4ac440e3a1fc71025cfd890556244708c7f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Nov 2010 07:40:27 -0600 Subject: [PATCH 411/462] gr2 cleanup original commit: f11e53c68ca1fbc4e11321f97776650b8758ace3 --- collects/mrlib/private/image-core-bitmap.rkt | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 7b6b2baf..949acdcb 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -72,14 +72,8 @@ instead of this scaling code, we use the dc<%>'s scaling code. w h (* w h NUM-CHANNELS))) - (let* ([bm (make-object bitmap% w h)] - [mask (make-object bitmap% w h)] - [bdc (make-object bitmap-dc% bm)]) - (send bdc set-argb-pixels 0 0 w h bytes #f) - (send bdc set-bitmap mask) - (send bdc set-argb-pixels 0 0 w h bytes #t) - (send bdc set-bitmap #f) - (send bm set-loaded-mask mask) + (let* ([bm (make-bitmap w h)]) + (send bm set-argb-pixels 0 0 w h bytes) bm)) (define (flip-bytes bmbytes w h) From 16f70bd22c4ecca0ffd1d9aa9b6efaf1eb2aaac5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Nov 2010 09:55:18 -0600 Subject: [PATCH 412/462] change the behavior for closing the preferences window. closes PR 11473 original commit: 2125535e06111dd9fb17203205161582c446bdab --- collects/framework/private/preferences.rkt | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 505fccaa..cb22974a 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -206,13 +206,14 @@ the state transitions / contracts are: (define (make-preferences-dialog) (letrec ([stashed-prefs (preferences:get-prefs-snapshot)] - [cancelled? #t] + [cancelled? #f] [frame-stashed-prefs% (class frame:basic% (inherit close) (define/override (on-subwindow-char receiver event) (cond [(eq? 'escape (send event get-key-code)) + (set! cancelled? #t) (close)] [else (super on-subwindow-char receiver event)])) @@ -222,7 +223,7 @@ the state transitions / contracts are: (define/override (show on?) (when on? ;; reset the flag and save new prefs when the window becomes visible - (set! cancelled? #t) + (set! cancelled? #f) (set! stashed-prefs (preferences:get-prefs-snapshot))) (super show on?)) (super-new))] @@ -280,9 +281,10 @@ the state transitions / contracts are: (for-each (λ (f) (f)) on-close-dialog-callbacks) - (set! cancelled? #f) (send frame close)))] - [cancel-callback (λ () (send frame close))]) + [cancel-callback (λ () + (set! cancelled? #t) + (send frame close))]) (new button% [label (string-constant revert-to-defaults)] [callback From eafc586bf3427dcd72bf6a1d4d1acf12b4bf01d3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 17:10:42 -0700 Subject: [PATCH 413/462] cocoa: fix race condition on window enabling original commit: 37d16cf8f81a5b486ca79d5c6b6695de5dc95455 --- collects/mred/private/wx/cocoa/canvas.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 551eed0d..7e3d0cdb 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -612,6 +612,7 @@ 1)])) (define/override (enable-window on?) + ;; in atomic mode (let ([on? (and on? (is-window-enabled?))]) (let ([w (tell content-cocoa window)]) (when (ptr-equal? content-cocoa (tell w firstResponder)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 0c37a04e..dbe29c72 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,9 +520,11 @@ (define/public (is-window-enabled?) enabled?) (define/public (enable on?) - (set! enabled? on?) - (enable-window on?)) + (atomically + (set! enabled? on?) + (enable-window on?))) (define/public (enable-window on?) + ;; in atomic mode (void)) (define block-all-mouse-events? #f) From 5953d2f3307ee407604dd87e24aa982a65a862e3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 19:57:38 -0700 Subject: [PATCH 414/462] fix eventspace as event original commit: c81ad90161104a1e02c172cb18753ff93fdfe452 --- collects/mred/private/wx/common/queue.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 5041babc..65df083d 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -196,6 +196,7 @@ (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] + [done-set? #t] [frames (make-hasheq)]) (let ([e (make-eventspace th @@ -212,8 +213,12 @@ (if (or (positive? count) (positive? (hash-count frames)) (not (null? (unbox timer)))) - (semaphore-try-wait? done-sema) - (semaphore-post done-sema)))] + (when done-set? + (set! done-set? #f) + (semaphore-try-wait? done-sema)) + (unless done-set? + (set! done-set? #t) + (semaphore-post done-sema))))] [enqueue (lambda (v q) (set! count (add1 count)) (check-done) From 5ccf03492b28964b299d1a526bdd6b41dbfd92ba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Nov 2010 12:35:25 -0700 Subject: [PATCH 415/462] don't GC an eventspace with a visible frame, etc. original commit: 9f9e23f551ad1b45c9d930a89bcec58f422c4b38 --- collects/mred/private/wx/common/queue.rkt | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 65df083d..14c8006b 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -176,6 +176,11 @@ [(< am bm) -1] [else 1])))) +;; This table refers to handle threads of eventspaces +;; that have an open window, etc., so that the eventspace +;; isn't GCed +(define active-eventspaces (make-hasheq)) + (define current-cb-box (make-parameter #f)) (define-mz scheme_add_managed (_fun _racket ; custodian @@ -192,7 +197,8 @@ (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) (for ([f (in-list (get-top-level-windows e))]) - (send f destroy)))) + (send f destroy)) + (hash-remove! active-eventspaces (eventspace-handler-thread e)))) (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] @@ -214,9 +220,11 @@ (positive? (hash-count frames)) (not (null? (unbox timer)))) (when done-set? + (hash-set! active-eventspaces th #t) (set! done-set? #f) (semaphore-try-wait? done-sema)) (unless done-set? + (hash-remove! active-eventspaces th) (set! done-set? #t) (semaphore-post done-sema))))] [enqueue (lambda (v q) From 467341591ec6eacc9e7df6cb81292e7de379770a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 07:55:41 -0700 Subject: [PATCH 416/462] fix {get,set}-event-type on mouse-event% Closes PR 11474 original commit: 8f9a8daa27dee721545915970eaa56b0c7ec4c30 --- collects/mred/private/wx/common/event.rkt | 56 +++++++++++------------ 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index e9820fe3..88f1fc5f 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -14,10 +14,11 @@ (super-new)) (defclass mouse-event% event% - ;; FIXME: check event-type - (init event-type) - (define et event-type) - (init-properties [[bool? left-down] #f] + (init-properties [[(symbol-in enter leave left-down left-up + middle-down middle-up + right-down right-up motion) + event-type]] + [[bool? left-down] #f] [[bool? middle-down] #f] [[bool? right-down] #f] [[exact-integer? x] 0] @@ -30,44 +31,45 @@ (init-properties [[bool? caps-down] #f]) (super-new [time-stamp time-stamp]) - (def/public (get-event-type) et) - (def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down left-up middle-down middle-up right-down right-up)] - [(left) '(left-down left-up)] - [(middle) '(middle-down middle-up)] - [(right) '(right-down right-up)])) + (and (memq event-type + (case button + [(any) '(left-down left-up middle-down middle-up right-down right-up)] + [(left) '(left-down left-up)] + [(middle) '(middle-down middle-up)] + [(right) '(right-down right-up)])) #t)) (def/public (button-down? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down middle-down right-down)] - [(left) '(left-down)] - [(middle) '(middle-down)] - [(right) '(right-down)])) + (and (memq event-type + (case button + [(any) '(left-down middle-down right-down)] + [(left) '(left-down)] + [(middle) '(middle-down)] + [(right) '(right-down)])) #t)) (def/public (button-up? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-up middle-up right-up)] - [(left) '(left-up)] - [(middle) '(middle-up)] - [(right) '(right-up)])) + (and (memq event-type + (case button + [(any) '(left-up middle-up right-up)] + [(left) '(left-up)] + [(middle) '(middle-up)] + [(right) '(right-up)])) #t)) (def/public (dragging?) - (and (eq? et 'motion) + (and (eq? event-type 'motion) (or left-down middle-down right-down))) (def/public (entering?) - (eq? et 'enter)) + (eq? event-type 'enter)) (def/public (leaving?) - (eq? et 'leave)) + (eq? event-type 'leave)) (def/public (moving?) - (eq? et 'motion))) + (eq? event-type 'motion))) (defclass key-event% event% (init-properties [[(make-alts symbol? char?) key-code] #\nul] @@ -91,9 +93,7 @@ list-box list-box-dclick text-field text-field-enter slider radio-box menu-popdown menu-popdown-none tab-panel) - event-type] - ;; FIXME: should have no default - 'button]) + event-type]]) (init [time-stamp 0]) (super-new [time-stamp time-stamp])) From 06ab79f133497bf5b0c6580e8e6939b42792c7b2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 15:39:02 -0700 Subject: [PATCH 417/462] cocoa: explicitly re-dispatch Cmd- key combinations original commit: 72d57d8db86b53adadef214fef051a78f9965bf5 --- collects/mred/private/wx/cocoa/menu-bar.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index b8c70ae5..3bf4b065 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -41,8 +41,16 @@ ;; Disable automatic handling of keyboard shortcuts, except for ;; the Apple menu (-a _BOOL (performKeyEquivalent: [_id evt]) - (and the-apple-menu - (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)))) + (or (and the-apple-menu + (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) + ;; Explicity send the event to the keyWindow: + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (tell r keyDown: evt) + #t)))))))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) From a82341289c0c1d4f779c94cdcd9f678a933a3b1a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 20:17:47 -0700 Subject: [PATCH 418/462] cocoa: avoid infinite loop on re-dispatch of command keys original commit: e627ccb5edb6e7c030325d6c62d82c170a83f06b --- collects/mred/private/wx/cocoa/menu-bar.rkt | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 3bf4b065..a8c95b94 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -35,6 +35,7 @@ "MrEd")) (define the-apple-menu #f) +(define recurring-for-command (make-parameter #f)) (define-objc-class MyBarMenu NSMenu [] @@ -44,13 +45,16 @@ (or (and the-apple-menu (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) ;; Explicity send the event to the keyWindow: - (let ([w (tell app keyWindow)]) - (and w - (let ([r (tell w firstResponder)]) - (and r - (begin - (tell r keyDown: evt) - #t)))))))) + (and + (not (recurring-for-command)) + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (parameterize ([recurring-for-command #t]) + (tell r keyDown: evt)) + #t))))))))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) From 726e476ea09009fa1633366b51ad0f0957b8b01c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Dec 2010 14:09:03 -0600 Subject: [PATCH 419/462] avoid saving the preferences on each keystroke in the find/replace dialog original commit: de0103129bb589fd59f618e117dde432ed1a6290 --- collects/framework/private/frame.rkt | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 9cff2880..0e9fa3d2 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -1693,15 +1693,22 @@ (define/augment (after-delete x y) (update-prefs) (inner (void) after-delete x y)) + (define timer #f) (define/private (update-prefs) - (preferences:set pref-sym - (let loop ([snip (find-first-snip)]) - (cond - [(not snip) '()] - [(is-a? snip string-snip%) - (cons (send snip get-text 0 (send snip get-count)) - (loop (send snip next)))] - [else (cons snip (loop (send snip next)))])))) + (unless timer + (set! timer (new timer% + [notify-callback + (λ () + (preferences:set pref-sym + (let loop ([snip (find-first-snip)]) + (cond + [(not snip) '()] + [(is-a? snip string-snip%) + (cons (send snip get-text 0 (send snip get-count)) + (loop (send snip next)))] + [else (cons snip (loop (send snip next)))]))))]))) + (send timer stop) + (send timer start 150 #t)) (define/override (get-keymaps) (editor:add-after-user-keymap search/replace-keymap (super get-keymaps))) (super-new) From 669ea4390ee94cb3863049c1305e9a10b9e1bb7a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 13:37:07 -0700 Subject: [PATCH 420/462] fix autowrap bitmap drawing so it isn't covered up by a selection original commit: e9710d08f5385c9251ba6dd88d4e70f96f247ca6 --- collects/mred/private/wxme/text.rkt | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index b8a4982e..050bfa9c 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5265,20 +5265,6 @@ (-startpos . > . (+ pcounter (mline-len line))))] [(hilite-some? hsxs hsxe hsys hsye old-style) (process-snips draw-first? #f old-style)]) - (when (and (positive? wrap-bitmap-width) - (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) - last - (rightx . >= . max-width) - (send auto-wrap-bitmap ok?)) - (let ([h (min (->long (send auto-wrap-bitmap get-height)) - (mline-bottombase line))] - [osfg (send old-style get-foreground)]) - (send dc draw-bitmap-section - auto-wrap-bitmap - (sub1 (+ max-width dx)) (+ (- bottombase h) dy) - 0 0 wrap-bitmap-width h - 'solid osfg))) - (let ([prevwasfirst (if hilite-some? (if (not (= hsxs hsxe)) @@ -5337,6 +5323,21 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) + + (when (and (positive? wrap-bitmap-width) + (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) + last + (rightx . >= . max-width) + (send auto-wrap-bitmap ok?)) + (let ([h (min (->long (send auto-wrap-bitmap get-height)) + (mline-bottombase line))] + [osfg (send old-style get-foreground)]) + (send dc draw-bitmap-section + auto-wrap-bitmap + (sub1 (+ max-width dx)) (+ (- bottombase h) dy) + 0 0 wrap-bitmap-width h + 'solid osfg))) + (let ([old-style (if draw-first? old-style From 1176e3aed60156be6773a2c6e0202302c62eeff3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 15:48:43 -0700 Subject: [PATCH 421/462] use dots for 'password style text-field% original commit: ec122a785ad01920eb851c4a2fdad9240b7f3ef0 --- collects/mred/private/wxtextfield.rkt | 83 +++++++++++++++++++++------ 1 file changed, 66 insertions(+), 17 deletions(-) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index e87ae2c8..6f4c7f39 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -1,9 +1,10 @@ -(module wxtextfield mzscheme +(module wxtextfield racket/base (require mzlib/class mzlib/class100 - (prefix wx: "kernel.ss") - (prefix wx: "wxme/text.ss") - (prefix wx: "wxme/editor-canvas.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/text.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" "check.ss" @@ -17,14 +18,63 @@ "editor.ss" "mrpopup.ss") - (provide (protect wx-text-field%)) + (provide (protect-out wx-text-field%)) + + (define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent)) + (define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid)) + + (define password-string-snip% + (class wx:string-snip% + (inherit get-count + get-style + get-text) + (super-new) + + (define delta 2) + (define (get-size) + (max 4 (send (send (get-style) get-font) get-point-size))) + + (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (let ([s (get-size)]) + (when w (set-box! w (* s (get-count)))) + (when h (set-box! h (+ s 2.0))) + (when descent (set-box! descent 1.0)) + (when space (set-box! space 1.0)) + (when lspace (set-box! lspace 0.0)) + (when rspace (set-box! rspace 0.0)))) + (define/override (partial-offset dc x y pos) + (let ([s (get-size)]) + (* s pos))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([s (get-size)] + [b (send dc get-brush)] + [p (send dc get-pen)] + [m (send dc get-smoothing)]) + (send dc set-pen no-pen) + (send dc set-brush black-brush) + (send dc set-smoothing 'aligned) + (for/fold ([x x]) ([i (in-range (get-count))]) + (send dc draw-ellipse (+ x delta) (+ y delta 1) (- s delta delta) (- s delta delta)) + (+ x s)) + (send dc set-pen p) + (send dc set-brush b) + (send dc set-smoothing m))) + (define/override (split pos first second) + (let ([a (new password-string-snip%)] + [b (new password-string-snip%)] + [c (get-count)]) + (send a insert (get-text 0 pos) pos) + (send b insert (get-text pos c) (- c pos)) + (set-box! first a) + (set-box! second b))))) (define text-field-text% - (class100 text% (cb ret-cb control set-cb-mgrs! record-text) + (class100 text% (cb ret-cb control set-cb-mgrs! record-text pw?) (rename [super-on-char on-char]) (inherit get-text last-position set-max-undo-history get-flattened-text) (private-field - [return-cb ret-cb]) + [return-cb ret-cb] + [password? pw?]) (private-field [block-callback 1] [callback @@ -42,7 +92,12 @@ (unless (and (or (eq? c #\return) (eq? c #\newline)) return-cb (return-cb (lambda () (callback 'text-field-enter) #t))) - (as-exit (lambda () (super-on-char e)))))))]) + (as-exit (lambda () (super-on-char e)))))))] + [on-new-string-snip + (lambda () + (if password? + (new password-string-snip%) + (super on-new-string-snip)))]) (augment [after-insert (lambda args @@ -91,7 +146,8 @@ (set! without-callback wc) (set! callback-ready cr)) (lambda (t) - (send c set-combo-text t)))]) + (send c set-combo-text t)) + (memq 'password style))]) (sequence (as-exit (lambda () @@ -202,14 +258,7 @@ (send e auto-wrap (and multi? (not (memq 'hscroll style)))) (let ([f font] [s (send (send e get-style-list) find-named-style "Standard")]) - (send s set-delta (let ([d (font->delta f)]) - (if (memq 'password style) - (begin - (send d set-face #f) - (send d set-family 'modern) - (send d set-delta-foreground "darkgray") - (send d set-delta-background "darkgray")) - d)))) + (send s set-delta (font->delta f))) (send c set-editor e) (send c set-line-count (if multi? 3 1)) (unless multi? (send c set-single-line)) From 1ed409f26c5ed492987a91c30fd031dc0c99eef9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 15:56:02 -0700 Subject: [PATCH 422/462] fix docs for `get-panel-background' original commit: 42dc83bbcd11ecc2e80af0cf18ac60d4a4e3db27 --- collects/scribblings/gui/miscwin-funcs.scrbl | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index fa69a652..dcc9cdb0 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -107,20 +107,24 @@ default is @racket['(cmd)]. Under X, the default is normally @defproc[(get-panel-background) (is-a?/c color%)]{ -Returns the background color of a panel (usually some shade of gray) - for the current platform. +Returns a shade of gray. +Historically, the result matched the color of +a @racket[panel%] background, but @racket[panel%] backgrounds can vary +on some platforms (e.g., when nested in a @racket[group-box-panel%]), +so the result is no longer guaranteed to be related to a +@racket[panel%]'s color. } @defproc[(get-highlight-background-color) (is-a?/c color%)]{ -Returns the color drawn behind selected text.} +Returns the color that is drawn behind selected text.} @defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ -Returns the color used to draw selected text or @racket[#f] if +Returns the color that is used to draw selected text or @racket[#f] if selected text is drawn with its usual color.} From f4d458d0fd64aa4b79f996522d279d1263e3137c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 20:48:23 -0700 Subject: [PATCH 423/462] gtk: fix clipboard; implement ye olde X selection original commit: 82ab45b11d3f890d4830248feb95f38dcfe98c56 --- collects/mred/private/wx/gtk/clipboard.rkt | 122 ++++++++++++--------- collects/mred/private/wx/gtk/queue.rkt | 13 ++- collects/mred/private/wx/gtk/types.rkt | 15 +++ collects/mred/private/wxme/text.rkt | 14 +-- 4 files changed, 104 insertions(+), 60 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 06f01340..142e2402 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -7,6 +7,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/freeze.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") @@ -16,11 +17,12 @@ has-x-selection? _GtkSelectionData gtk_selection_data_get_length - gtk_selection_data_get_data)) + gtk_selection_data_get_data + primary-atom + get-selection-eventspace)) (define (has-x-selection?) #t) -(define _GdkAtom _int) (define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) @@ -81,63 +83,71 @@ (define clear_owner (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) +(define primary-atom (gdk_atom_intern "PRIMARY" #t)) +(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t)) + +(define the-x-selection-driver #f) (defclass clipboard-driver% object% (init-field [x-selection? #f]) + (when x-selection? + (set! the-x-selection-driver this)) + (define client #f) (define client-data #f) + (define client-types #f) + (define client-orig-types #f) (define cb (gtk_clipboard_get (if x-selection? - (gdk_atom_intern "CLIPBOARD" #t) - (gdk_atom_intern "PRIMARY" #t)))) + primary-atom + clipboard-atom))) (define self-box #f) (define/public (get-client) client) - (define/public (set-client c types) - (if x-selection? - ;; For now, we can't call it on demand, so we don't call at all: - (queue-event (send c get-client-eventspace) - (lambda () - (send c on-replaced))) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: - (let ([all-data (for/list ([t (in-list types)]) - (send c get-data t))] - [types (for/list ([t (in-list types)]) - (if (equal? t "TEXT") - "UTF8_STRING" - t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (define/public (set-client c orig-types) + ;; In clipboard mode (as opposed to X selection), we can get the data + ;; now, so it's ready if anyone asks: + (let ([all-data (if x-selection? + #f + (for/list ([t (in-list orig-types)]) + (send c get-data t)))] + [types (for/list ([t (in-list orig-types)]) + (if (equal? t "TEXT") + "UTF8_STRING" + t))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings))))) + (free target-strings)))) (define/public (replaced s-box) ;; Called in Gtk event-dispatch thread --- atomically with respect @@ -148,19 +158,27 @@ (when c (set! client #f) (set! client-data #f) + (set! client-types #f) + (set! client-orig-types #f) (queue-event (send c get-client-eventspace) (lambda () (send c on-replaced)))))) (free-immobile-cell s-box)) (define/public (provide-data i sel-data) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode; if it's the selection (not clipboard), + ;; then hopefully we're in the right eventspace (let ([bstr (if client - (list-ref client-data i) + (if client-data + (list-ref client-data i) + (constrained-reply (send client get-client-eventspace) + (lambda () + (send client get-data + (list-ref client-orig-types i))) + #"")) #"")]) (gtk_selection_data_set sel-data - (gdk_atom_intern "UTF8_STRING" #t) + (gdk_atom_intern (list-ref client-types i) #t) 8 bstr (bytes-length bstr)))) @@ -190,3 +208,9 @@ (gobject-unref pixbuf))))) (super-new)) + +(define (get-selection-eventspace) + (and the-x-selection-driver + (let ([c (send the-x-selection-driver get-client)]) + (and c + (send c get-client-eventspace))))) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 80855f65..fb371bf3 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -6,6 +6,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" + "clipboard.rkt" "const.rkt" "w32.rkt" "unique.rkt") @@ -163,11 +164,19 @@ (let* ([gtk (gtk_get_event_widget evt)] [wx (and gtk (widget-hook gtk))]) (cond - [(and (= (ptr-ref evt _int) GDK_EXPOSE) + [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE) wx (send wx direct-update?)) (gtk_main_do_event evt)] - [(and wx (send wx get-eventspace)) + [(or + ;; event for a window that we control? + (and wx (send wx get-eventspace)) + ;; event to get X selection data? + (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0274dc50..0fb02212 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,6 +8,8 @@ _GdkScreen _gpointer _GType + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -27,6 +29,8 @@ (struct-out GdkEventConfigure) _GdkEventExpose _GdkEventExpose-pointer (struct-out GdkEventExpose) + _GdkEventSelection _GdkEventSelection-pointer + (struct-out GdkEventSelection) (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -50,6 +54,8 @@ (define _gfloat _float) (define _GdkEventType _int) +(define _GdkAtom _int) + (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] [send_event _byte] @@ -123,6 +129,15 @@ [width _int] [height _int])) +(define-cstruct _GdkEventSelection ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) + (define-cstruct _GdkRectangle ([x _int] [y _int] [width _int] diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 050bfa9c..be32c886 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -49,12 +49,7 @@ (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) (define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) (define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) -(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") -(define outline-nonowner-brush (let ([b (new brush%)]) - (send b set-color "BLACK") - (send b set-stipple (make-object bitmap% xpattern 16 16)) - (send b set-style 'xor) - b)) +(define outline-nonowner-brush outline-brush) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -5257,9 +5252,10 @@ hilite-some? hsxs hsxe hsys hsye old-style)))))))))) (let*-values ([(draw-first?) - (or (not (showcaret>= show-caret 'show-caret)) - (and s-caret-snip (not (pair? show-caret))) - (not hilite-on?) + (or (and (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?)) + (not show-xsel?)) (= -startpos -endpos) (-endpos . < . pcounter) (-startpos . > . (+ pcounter (mline-len line))))] From 27c6805b43728efc0f8e8122cc500c34f0bd84c2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 06:16:51 -0700 Subject: [PATCH 424/462] gtk: fix clipboard problems on 64-bit mode; provide more text formats original commit: 7a37b07e263a72ba40b7aed9c759a2ed84b4bb08 --- collects/mred/private/wx/common/freeze.rkt | 4 +- collects/mred/private/wx/gtk/clipboard.rkt | 88 ++++++++++++---------- collects/mred/private/wx/gtk/queue.rkt | 8 +- collects/mred/private/wx/gtk/types.rkt | 2 +- 4 files changed, 56 insertions(+), 46 deletions(-) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 92c15665..7ee55836 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -40,9 +40,7 @@ ;; Ideally, this would count as an error that we can fix. It seems that we ;; don't always have enough control to use the right eventspace with a ;; retry point, though, so just bail out with the default. - #; - (internal-error (format "constrained-reply not within an unfreeze point for ~s" - thunk)) + #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 142e2402..82bee0c6 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -108,50 +108,62 @@ (define/public (get-client) client) (define/public (set-client c orig-types) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: (let ([all-data (if x-selection? + ;; In X selection mode, get the data on demand: #f + ;; In clipboard mode, we can get the data + ;; now, so it's ready if anyone asks: (for/list ([t (in-list orig-types)]) (send c get-data t)))] [types (for/list ([t (in-list orig-types)]) (if (equal? t "TEXT") "UTF8_STRING" t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - (set! client-types types) - (set! client-orig-types orig-types) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (let-values ([(orig-types types all-data) + ;; For "TEXT", provide "UTF8_STRING", "STRING", and "TEXT": + (if (member "TEXT" orig-types) + (values (append orig-types (list "TEXT" "TEXT")) + (append types (list "STRING" "TEXT")) + (and all-data (append all-data + (let loop ([all-data all-data] + [orig-types orig-types]) + (if (equal? "TEXT" (car orig-types)) + (list (car all-data) (car all-data)) + (loop (cdr all-data) (cdr orig-types))))))) + (values orig-types types all-data))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings)))) + (free target-strings))))) (define/public (replaced s-box) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode (when (ptr-equal? s-box self-box) (set! self-box #f) (let ([c client]) @@ -177,11 +189,11 @@ (list-ref client-orig-types i))) #"")) #"")]) - (gtk_selection_data_set sel-data - (gdk_atom_intern (list-ref client-types i) #t) - 8 - bstr - (bytes-length bstr)))) + (gtk_selection_data_set sel-data + (gdk_atom_intern (list-ref client-types i) #t) + 8 + bstr + (bytes-length bstr)))) (define/public (get-data format) (let ([process (lambda (v) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index fb371bf3..110e8932 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -173,10 +173,10 @@ (and wx (send wx get-eventspace)) ;; event to get X selection data? (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) - (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) - (= (GdkEventSelection-selection s) - primary-atom)) - (get-selection-eventspace))) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0fb02212..0dc4d8c1 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -54,7 +54,7 @@ (define _gfloat _float) (define _GdkEventType _int) -(define _GdkAtom _int) +(define _GdkAtom _long) (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] From aff73a02180c00bace3a9ce8556c5aaa843ceedd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 06:20:07 -0700 Subject: [PATCH 425/462] gtk: fix GdkAtom type original commit: 74d858ceedf93c1eb95be2f4cadbdab79f5bdfd8 --- collects/mred/private/wx/gtk/types.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0dc4d8c1..20bb567c 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -54,7 +54,7 @@ (define _gfloat _float) (define _GdkEventType _int) -(define _GdkAtom _long) +(define _GdkAtom _intptr) (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] From 72b8c62748d5877372a56499db6067128c0fe12b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 07:04:38 -0700 Subject: [PATCH 426/462] win32: fix font used to size controls original commit: b0a746c701d2bc2b9380d66f98eedbd3f94736e0 --- collects/mred/private/wx/win32/window.rkt | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index caca412b..3ca1072c 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -322,7 +322,7 @@ [dc (make-object bitmap-dc% bm)]) (set! measure-dc dc))) (send measure-dc set-font (or font - (make-object font% 8 'system))) + (get-default-control-font))) (let-values ([(w h d a) (let loop ([label label]) (cond [(null? label) (values 0 0 0 0)] @@ -689,6 +689,18 @@ ;; ---------------------------------------- +(define default-control-font #f) +(define (get-default-control-font) + (unless default-control-font + (set! default-control-font + (make-object font% + (get-theme-font-size) + (get-theme-font-face) + 'system + 'normal 'normal #f 'default + #t))) + default-control-font) + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) From 0e3f40b8c4a6f8b3fecbd771b64dea75385e211c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 11:52:42 -0700 Subject: [PATCH 427/462] cocoa: hack around NSApplication's handling of command-line arguments original commit: 3479f5fb92a68b8bcdd18c557ca03c17f43cd9e6 --- collects/mred/private/wx/cocoa/queue.rkt | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index d6ca67c5..a66bf5d9 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -29,9 +29,21 @@ queue-event yield) -(import-class NSApplication NSAutoreleasePool NSColor) +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) (import-protocol NSApplicationDelegate) +;; Extreme hackery to hide original arguments from +;; NSApplication, because NSApplication wants to turn +;; the arguments into `application:openFile:' calls. +;; To hide the arguments, we replace the implementation +;; of `arguments' in the NSProcessInfo object. +(define (hack-argument-replacement self method) + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file))) + count: #:type _NSUInteger 1)) +(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))]) + (void (method_setImplementation m hack-argument-replacement))) + (define app (tell NSApplication sharedApplication)) (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) From a2910e89c5f55909e9b21aefe0a873955d7ca8be Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 15:56:08 -0600 Subject: [PATCH 428/462] Adds an indicator that shows when framework prefs are being written. Performance grinds to a halt when the preference file is too large or written too often. Hopefully the indicator will help us identify this phenonmenon. original commit: fbd7bdff5454465e2df0f99defdb64a304c1a135 --- collects/framework/preferences.rkt | 93 +++++++++++++++++++++------- collects/framework/private/frame.rkt | 61 +++++++++++++++++- 2 files changed, 127 insertions(+), 27 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 9c74cff4..ad4a2482 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -132,31 +132,58 @@ the state transitions / contracts are: ;; set : symbol any -> void ;; updates the preference ;; exported - (define (multi-set ps values) - (for-each - (λ (p value) - (cond - [(pref-default-set? p) - (let ([default (hash-ref defaults p)]) - (unless ((default-checker default) value) - (error 'preferences:set - "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" - p value)) - (check-callbacks p value) - (hash-set! preferences p value))] - [(not (pref-default-set? p)) - (raise-unknown-preference-error - 'preferences:set "tried to set the preference ~e to ~e, but no default is set" - p - value)])) - ps values) - ((preferences:low-level-put-preferences) - (map add-pref-prefix ps) - (map (λ (p value) (marshall-pref p value)) - ps - values)) - (void)) + (dynamic-wind + (λ () + (call-pref-save-callbacks #t)) + (λ () + (for-each + (λ (p value) + (cond + [(pref-default-set? p) + (let ([default (hash-ref defaults p)]) + (unless ((default-checker default) value) + (error 'preferences:set + "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" + p value)) + (check-callbacks p value) + (hash-set! preferences p value))] + [(not (pref-default-set? p)) + (raise-unknown-preference-error + 'preferences:set "tried to set the preference ~e to ~e, but no default is set" + p + value)])) + ps values) + ((preferences:low-level-put-preferences) + (map add-pref-prefix ps) + (map (λ (p value) (marshall-pref p value)) + ps + values)) + (void)) + (λ () + (call-pref-save-callbacks #f)))) + +(define pref-save-callbacks '()) + +(define (preferences:register-save-callback f) + (define key (gensym)) + (set! pref-save-callbacks (cons (list key f) pref-save-callbacks)) + key) + +(define (preferences:unregister-save-callback k) + (set! pref-save-callbacks + (let loop ([callbacks pref-save-callbacks]) + (cond + [(null? callbacks) '()] + [else + (let ([cb (car callbacks)]) + (if (eq? (list-ref cb 0) k) + (cdr callbacks) + (cons cb (loop (cdr callbacks)))))])))) + +(define (call-pref-save-callbacks b) + (for ([cb (in-list pref-save-callbacks)]) + ((list-ref cb 1) b))) (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference @@ -437,6 +464,24 @@ the state transitions / contracts are: @{@scheme[(preferences:restore-defaults)] restores the users' configuration to the default preferences.}) + (proc-doc/names + preferences:register-save-callback + (-> (-> boolean? any) symbol?) + (callback) + @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once + before the preferences file is written, with @racket[#t], and once after it is written, with + @racket[#f}. Registration returns a key for use with @racket{preferences:unregister-save-callback}. + Caveats: + @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} + @item{Pre- and post-write notifications are not necessarily paired; unregistration + may cancel the post-write notification before it occurs.}}}) + + (proc-doc/names + preferences:unregister-save-callback + (-> symbol? void?) + (key) + @{Unregisters the save callback associated with @racket{key}.}) + (proc-doc/names exn:make-unknown-preference (string? continuation-mark-set? . -> . exn:unknown-preference?) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 0e9fa3d2..c42b2d89 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -560,6 +560,7 @@ (λ (l) (if (memq outer-info-panel l) (begin (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (list rest-panel)) l)))] [else @@ -569,6 +570,7 @@ l (begin (register-gc-blit) + (register-pref-save-callback) (list rest-panel outer-info-panel)))))])) [define close-panel-callback @@ -580,6 +582,7 @@ (define/augment (on-close) (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (close-panel-callback) (memory-cleanup) (inner (void) on-close)) @@ -637,6 +640,12 @@ [(<= n 99) (format "0~a" n)] [else (number->string n)])) + (define pref-save-canvas #f) + (when checkout-or-nightly? + (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + ; only for checkouts and nightly build users (when show-memory-text? (let* ([panel (new horizontal-panel% @@ -657,7 +666,6 @@ (set! memory-canvases (remq ec memory-canvases)))) (send panel stretchable-width #f))) - [define lock-canvas (make-object lock-canvas% (get-info-panel))] [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] @@ -670,6 +678,25 @@ (send onb get-height) onb offb)))) + (define pref-save-callback-registration #f) + (inherit get-eventspace) + (define/private (register-pref-save-callback) + (when pref-save-canvas + (set! pref-save-callback-registration + (preferences:register-save-callback + (λ (start?) + (cond + [(eq? (current-thread) (eventspace-handler-thread (get-eventspace))) + (send pref-save-canvas set-on? start?)] + [else + (queue-callback + (λ () + (send pref-save-canvas set-on? start?)))])))))) + (define/private (unregister-pref-save-callback) + (when pref-save-callback-registration + (preferences:unregister-save-callback pref-save-callback-registration))) + (register-pref-save-callback) + (unless (preferences:get 'framework:show-status-line) (send super-root change-children (λ (l) @@ -2415,14 +2442,16 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) -(define memory-canvases '()) -(define show-memory-text? +(define checkout-or-nightly? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repo-time-stamp"))) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (let ([fw (collection-path "framework")]) (directory-exists? (build-path fw 'up 'up ".git")))))) +(define memory-canvases '()) +(define show-memory-text? checkout-or-nightly?) + (define bday-click-canvas% (class canvas% (define/override (on-event evt) @@ -2434,6 +2463,32 @@ [else (super on-event evt)])) (super-new))) +(define pref-save-canvas% + (class canvas% + (define on? #f) + (define indicator "P") + (define/override (on-paint) + (cond + [on? + (let-values ([(cw ch) (get-client-size)]) + (send (get-dc) draw-text indicator + (- (/ cw 2) (/ indicator-width 2)) + (- (/ ch 2) (/ indicator-height 2))))])) + (define/public (set-on? new-on?) + (set! on? new-on?) + (send (get-dc) erase) + (on-paint) + (flush)) + + (inherit get-dc flush get-client-size min-width) + (super-new [stretchable-width #f] + [style '(transparent)]) + + (define-values (indicator-width indicator-height) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) + (values tw th))) + (min-width (+ (inexact->exact (ceiling indicator-width)) 4)))) + (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) From 21a36a6e518274c0681fb5ea12f53be0915f30f5 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 19:26:24 -0600 Subject: [PATCH 429/462] Fixes doc typos original commit: 5f0430a5abcae4ae69612923e755759a05174a54 --- collects/framework/preferences.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index ad4a2482..8f5fd3d0 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -470,7 +470,7 @@ the state transitions / contracts are: (callback) @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once before the preferences file is written, with @racket[#t], and once after it is written, with - @racket[#f}. Registration returns a key for use with @racket{preferences:unregister-save-callback}. + @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. Caveats: @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} @item{Pre- and post-write notifications are not necessarily paired; unregistration @@ -480,7 +480,7 @@ the state transitions / contracts are: preferences:unregister-save-callback (-> symbol? void?) (key) - @{Unregisters the save callback associated with @racket{key}.}) + @{Unregisters the save callback associated with @racket[key].}) (proc-doc/names exn:make-unknown-preference From 4323d16f958d2dea599f274c5fa7d0c61386aaf9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Dec 2010 16:57:22 -0700 Subject: [PATCH 430/462] win64: fix GetWindowLong to use Ptr variant original commit: 6d1db909c4f08728f2aab3928473eabc4f628c3d --- collects/mred/private/wx/win32/utils.rkt | 8 ++++---- collects/mred/private/wx/win32/wndclass.rkt | 22 ++++++++++----------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index f100116b..727bc736 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -19,8 +19,8 @@ GetLastError - GetWindowLongW - SetWindowLongW + GetWindowLongPtrW + SetWindowLongPtrW SendMessageW SendMessageW/str GetSysColor GetRValue GetGValue GetBValue make-COLORREF CreateBitmap @@ -67,8 +67,8 @@ (error who "call failed (~s)" (GetLastError))) -(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) -(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) +(define-user32 GetWindowLongPtrW (_wfun _HWND _int -> _pointer)) +(define-user32 SetWindowLongPtrW (_wfun _HWND _int _pointer -> _pointer)) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 8bcf8f4d..880209d6 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -37,21 +37,21 @@ (define (register-hwnd! hwnd) (hash-set! all-hwnds (cast hwnd _pointer _intptr) #t) (let ([c (malloc-immobile-cell (vector #f #f #f))]) - (void (SetWindowLongW hwnd GWLP_USERDATA c)))) + (void (SetWindowLongPtrW hwnd GWLP_USERDATA c)))) (define (set-hwnd-wx! hwnd wx) - (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] + (let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) (vector-set! v 0 (make-weak-box wx)))) (define (set-hwnd-ctlproc! hwnd save-ptr ctlproc) - (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] + (let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) (vector-set! v 1 ctlproc) (vector-set! v 2 save-ptr))) (define (hwnd->wx hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) (and c (let ([v (ptr-ref c _racket)]) (and v (let ([wb (vector-ref v 0)]) @@ -67,12 +67,12 @@ wx)))) (define (hwnd->ctlproc hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) (and c (let ([v (ptr-ref c _racket)]) (and v (vector-ref v 1)))))) (define (hwnd->ctlproc-fptr hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) (and c (let ([v (ptr-ref c _racket)]) (and v (vector-ref v 2)))))) @@ -82,10 +82,10 @@ ;; call in atomic mode: (define (unregister-hwnd! hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) (when c (free-immobile-cell c) - (SetWindowLongW hwnd GWLP_USERDATA #f)) + (SetWindowLongPtrW hwnd GWLP_USERDATA #f)) (hash-remove! all-hwnds (cast hwnd _pointer _intptr)))) ;; ---------------------------------------- @@ -122,7 +122,7 @@ (let ([default-ctlproc (hwnd->ctlproc w)]) (if (= msg WM_DESTROY) (begin - (SetWindowLongW w GWLP_WNDPROC (hwnd->ctlproc-fptr w)) + (SetWindowLongPtrW w GWLP_WNDPROC (hwnd->ctlproc-fptr w)) (unregister-hwnd! w) (default-ctlproc w msg wParam lParam)) (let ([wx (hwnd->wx w)]) @@ -135,10 +135,10 @@ (define control_proc (function-ptr control-proc _WndProc)) (define (subclass-control hwnd) - (let* ([fptr (GetWindowLongW hwnd GWLP_WNDPROC)] + (let* ([fptr (GetWindowLongPtrW hwnd GWLP_WNDPROC)] [old-control-proc (function-ptr fptr _WndProc)]) (set-hwnd-ctlproc! hwnd fptr old-control-proc) - (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) + (SetWindowLongPtrW hwnd GWLP_WNDPROC control_proc))) (define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) From 42e15fefdbfcf1cb1d2d0516bde701d67e4334e0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Dec 2010 12:39:45 -0700 Subject: [PATCH 431/462] win32: fix setwindowlongptr binding for 32-bit mode original commit: fd79abcc1fd258c21803ab87d143b10d796aa4ab --- collects/mred/private/wx/win32/utils.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 727bc736..bf9020a1 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -67,8 +67,16 @@ (error who "call failed (~s)" (GetLastError))) -(define-user32 GetWindowLongPtrW (_wfun _HWND _int -> _pointer)) -(define-user32 SetWindowLongPtrW (_wfun _HWND _int _pointer -> _pointer)) +(define is-win64? + (equal? "win32\\x86_64" + (path->string (system-library-subpath #f)))) + +(define GetWindowLongPtrW + (get-ffi-obj (if is-win64? 'GetWindowLongPtrW 'GetWindowLongW) user32-lib + (_wfun _HWND _int -> _pointer))) +(define SetWindowLongPtrW + (get-ffi-obj (if is-win64? 'SetWindowLongPtrW 'SetWindowLongW) user32-lib + (_wfun _HWND _int _pointer -> _pointer))) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) From 00478aba9bb5c9f3de10c2463e340a60baed9a90 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Dec 2010 19:29:53 -0600 Subject: [PATCH 432/462] patch so that the alt key does not crash drracket (windows) original commit: f818aa56bf45ec1448aecd3fea4739a1eb96f5c1 --- collects/mred/private/wx/win32/window.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 3ca1072c..99e148e0 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -155,7 +155,7 @@ (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w msg wParam lParam #f #f))] + (do-key w msg wParam lParam #f #f default))] [(= msg WM_KEYDOWN) (do-key w msg wParam lParam #f #f default)] [(= msg WM_KEYUP) From 867670281c5b17dc0f27bc11704b25f4de8a08a9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Dec 2010 19:33:46 -0600 Subject: [PATCH 433/462] on second thought, maybe this is the right last argument original commit: 39008f2130b0eee4e41f6bd96dd5cf13d7474064 --- collects/mred/private/wx/win32/window.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 99e148e0..5abf242e 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -155,7 +155,7 @@ (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w msg wParam lParam #f #f default))] + (do-key w msg wParam lParam #f #f void))] [(= msg WM_KEYDOWN) (do-key w msg wParam lParam #f #f default)] [(= msg WM_KEYUP) From b5bc84e5ac6a8c47c17bcbb4588f5dce1f24f99f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 7 Dec 2010 07:03:55 -0600 Subject: [PATCH 434/462] added missing require (as suggested by Matthew) so now pasting works. original commit: 0a313888c4d7f0eec66eac2c9b2931b97cb35b94 --- collects/mred/private/wx/win32/clipboard.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt index 3b999c69..bf16d1dc 100644 --- a/collects/mred/private/wx/win32/clipboard.rkt +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -10,7 +10,8 @@ "const.rkt" "../../syntax.rkt" "wndclass.rkt" - "hbitmap.rkt") + "hbitmap.rkt" + "../common/local.rkt") (provide (protect-out clipboard-driver% From 02522b73e4d1b9d932a6ef298a54e4cc886ecedf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Dec 2010 19:56:02 -0700 Subject: [PATCH 435/462] cocoa: allow default handling of Cmd-` for cycling windows Closes PR 11499 but it's not clear that this is the right fix for all users original commit: 355cf25b5f84f72dacc2a729ae6d156d203b3998 --- collects/mred/private/wx/cocoa/menu-bar.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index a8c95b94..2a3fde20 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -46,7 +46,12 @@ (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) ;; Explicity send the event to the keyWindow: (and + ;; Don't go into an infinite loop: (not (recurring-for-command)) + ;; Don't handle Cmd-` for cycling through windows: + ;; [Is this right for all locales?] + (not (equal? "`" (tell #:type _NSString evt characters))) + ;; Otherwise, try to dispatch to the first respnder: (let ([w (tell app keyWindow)]) (and w (let ([r (tell w firstResponder)]) From 0591eccbe6b94e9eddfc05a6b342365f964912e0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 8 Dec 2010 21:26:35 -0600 Subject: [PATCH 436/462] changed the 'cancel' button to say something more accurate closes PR 11473 original commit: 81de0c133765cd75235ba29b9601fa4a69999bde --- collects/framework/private/frame.rkt | 2 +- collects/framework/private/preferences.rkt | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 66d63e46..4fb8cdae 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -761,7 +761,7 @@ (let-values ([(cw _4) (get-client-size)] [(tw _1 _2 _3) (send dc get-text-extent str normal-control-font)]) (when (< cw tw) - (min-client-width (inexact->exact (floor tw))))))) + (min-client-width (inexact->exact (ceiling tw))))))) (define/override (on-paint) (let ([dc (get-dc)]) (send dc set-font normal-control-font) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index cb22974a..2d18ffba 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -295,7 +295,9 @@ the state transitions / contracts are: (gui-utils:ok/cancel-buttons bottom-panel ok-callback - (λ (a b) (cancel-callback))) + (λ (a b) (cancel-callback)) + (string-constant ok) + (string-constant undo-changes)) (make-object grow-box-spacer-pane% bottom-panel) (send* bottom-panel (stretchable-height #f) From 3c58e557300a6175db84b220e6eca16fdfc35229 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 9 Dec 2010 07:52:54 -0600 Subject: [PATCH 437/462] added set-orientation method to panel:dragable (lets the panels change from being vertically aligned to horizontally aligned, even after they have been created) original commit: 9a485dd49270da20445eeb1c8b664f8f12b414ea --- collects/framework/private/panel.rkt | 23 ++++++++++++---------- collects/scribblings/framework/panel.scrbl | 6 ++++++ 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index c2efa530..270eb3b4 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -182,9 +182,15 @@ (define dragable-mixin (mixin (window<%> area-container<%>) (dragable<%>) (init parent) - - (define/public (get-vertical?) - (error 'get-vertical "abstract method")) + + (init-field vertical?) + + (define/public-final (get-vertical?) vertical?) + (define/public-final (set-orientation h?) + (define v? (not h?)) + (unless (eq? vertical? v?) + (set! vertical? v?) + (container-flow-modified))) (define/private (min-extent child) (let-values ([(w h) (send child get-graphical-min-size)]) (if (get-vertical?) @@ -413,18 +419,15 @@ (stretchable-height #f) (min-height 10))) - (define vertical-dragable-mixin (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #t) - (super-instantiate ()))) + (super-new [vertical? #t]))) (define horizontal-dragable-mixin (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #f) - (super-instantiate ()))) + (super-new [vertical? #f]))) - (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) + (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin panel%))) - (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%))) + (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) diff --git a/collects/scribblings/framework/panel.scrbl b/collects/scribblings/framework/panel.scrbl index 19541b84..e3cd08d5 100644 --- a/collects/scribblings/framework/panel.scrbl +++ b/collects/scribblings/framework/panel.scrbl @@ -98,6 +98,12 @@ horizontally aligned. } + + @defmethod[(set-orientation [horizontal? boolean?]) void?]{ + Sets the orientation of the panel, switching it from behaving + like a @racket[panel:horizontal-dragable<%>] and + @racket[panel:vertical-dragable<%>]. + } } @definterface[panel:vertical-dragable<%> (panel:dragable<%>)]{ A panel that implements From 2b7d3981c024645dbba7da65b16bfd7e4b94efd4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Dec 2010 15:18:39 -0700 Subject: [PATCH 438/462] win32: fix alt-combination handling original commit: 518cff7b6362be675d506dc90175fe5be455e7e0 --- collects/mred/private/wx/win32/window.rkt | 28 +++++++++++++---------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 5abf242e..061e3357 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -150,22 +150,26 @@ [(= msg WM_KILLFOCUS) (queue-window-event this (lambda () (on-kill-focus))) 0] - [(and (= msg WM_SYSKEYDOWN) - (or (= wParam VK_MENU) (= wParam VK_F4))) ;; F4 is close - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key w msg wParam lParam #f #f void))] + [(= msg WM_SYSKEYDOWN) + (let ([result (if (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close + (begin + (unhide-cursor) + (default w msg wParam lParam)) + 0)]) + (do-key w msg wParam lParam #f #f void) + result)] [(= msg WM_KEYDOWN) (do-key w msg wParam lParam #f #f default)] [(= msg WM_KEYUP) (do-key w msg wParam lParam #f #t default)] - [(and (= msg WM_SYSCHAR) - (= wParam VK_MENU)) - (unhide-cursor) - (begin0 - (default w msg wParam lParam) - (do-key w msg wParam lParam #t #f void))] + [(= msg WM_SYSCHAR) + (let ([result (if (= wParam VK_MENU) + (begin + (unhide-cursor) + (default w msg wParam lParam)) + 0)]) + (do-key w msg wParam lParam #t #f void) + result)] [(= msg WM_CHAR) (do-key w msg wParam lParam #t #f default)] [(= msg WM_COMMAND) From 5cc99c019d91d691e7d6441a0ecaa881b091abe7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Dec 2010 17:38:20 -0700 Subject: [PATCH 439/462] win32: fix delete key Closes PR 11519 original commit: b16f8fb16a7efe9e62e6cb9d20aafe15c6a7d9b8 --- collects/mred/private/wx/win32/key.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index a34a6760..4bb96647 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -70,7 +70,7 @@ VK_PRINT 'print VK_EXECUTE 'execute VK_INSERT 'insert - VK_DELETE 'delete + VK_DELETE #\rubout VK_HELP 'help VK_NUMPAD0 'numpad0 VK_NUMPAD1 'numpad1 From d1d4a77960a380cdf90d96dde0ba91c343ba7796 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Dec 2010 17:43:37 -0700 Subject: [PATCH 440/462] win32: fix key-release events original commit: 3aad886019653bbabefe07b04385d9fd153bcaef --- collects/mred/private/wx/win32/key.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 4bb96647..4ad9446f 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -215,12 +215,13 @@ (if just-check? #t (let* ([id (if (number? id) (integer->char id) id)] + [key-id (if (equal? id #\033) + 'escape + id)] [e (new key-event% [key-code (if is-up? 'release - (if (equal? id #\033) - 'escape - id))] + key-id)] [shift-down shift-down?] [control-down control-down?] [meta-down #f] @@ -229,5 +230,7 @@ [y 0] [time-stamp 0] [caps-down caps-down?])]) + (when is-up? + (send e set-key-release-code key-id)) e)))))) From 5e79bae3565105fffcbcea32d8b1b11e6a5278db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Dec 2010 18:05:51 -0700 Subject: [PATCH 441/462] win32: fix alt vs. meta; fix alt- menu dropdown original commit: e929f62d11e56493e7cd5cdf49e66836a5511b99 --- collects/mred/private/wx/win32/frame.rkt | 5 ++++- collects/mred/private/wx/win32/key.rkt | 4 ++-- collects/mred/private/wx/win32/menu-bar.rkt | 4 ++++ collects/mred/private/wx/win32/menu.rkt | 7 ++++++- 4 files changed, 16 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 4bbfcddf..0c42e5d0 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -500,6 +500,9 @@ (define/public (set-title s) (atomically (set! saved-title s) - (SetWindowTextW (get-hwnd) (string-append s (if modified? "*" "")))))) + (SetWindowTextW (get-hwnd) (string-append s (if modified? "*" ""))))) + (define/public (popup-menu-with-char c) + (DefWindowProcW hwnd WM_SYSKEYDOWN (char->integer c) (arithmetic-shift 1 29)) + (DefWindowProcW hwnd WM_SYSCHAR (char->integer c) (arithmetic-shift 1 29)))) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 4ad9446f..e394a6b4 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -224,8 +224,8 @@ key-id)] [shift-down shift-down?] [control-down control-down?] - [meta-down #f] - [alt-down alt-down?] + [meta-down alt-down?] + [alt-down #f] [x 0] [y 0] [time-stamp 0] diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index cdbf1c0f..089b8301 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -55,6 +55,10 @@ (send m set-parent this lbl hmenu))) (refresh)) + (define/public (popup-menu-with-char c) + (when parent + (send parent popup-menu-with-char c))) + (define/public (set-parent f) (SetMenu (send f get-hwnd) hmenu) (set! parent f) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 1686660a..c14d1632 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -49,7 +49,12 @@ hmenu lbl)) - (def/public-unimplemented select) + (define/public (select mb) + (when parent + (let ([m (regexp-match #rx"&[^&]" label)]) + (when m + (send parent popup-menu-with-char (string-ref (car m) 1)))))) + (def/public-unimplemented get-font) (def/public-unimplemented set-width) (def/public-unimplemented set-title) From 3f363bcfd2871e2051fc75c6bed4c303c5c9d7e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Dec 2010 21:06:11 -0700 Subject: [PATCH 442/462] win32: mouse-wheel events Closes PR 11520 original commit: cadc1289944353d5e7783a4fe81a376f731cd50b --- collects/mred/private/wx/win32/key.rkt | 14 +++++++++----- collects/mred/private/wx/win32/window.rkt | 10 ++++++++++ 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index e394a6b4..fd14fc19 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -121,9 +121,12 @@ [caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))] [alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)]) (let-values ([(id other-shift other-altgr other-shift-altgr) - (if is-char? - ;; wParam is a character - (let ([id wParam] + (cond + [(symbol? wParam) + (values wParam #f #f #f)] + [is-char? + ;; wParam is a character or symbol + (let ([id wParam] [sc (THE_SCAN_CODE lParam)]) ;; Remember scan codes to help with some key-release events: (when (byte? id) @@ -153,7 +156,8 @@ (values id s a sa) ;; different AltGr (values id s o sa))) - (values id s a sa)))))) + (values id s a sa))))))] + [else ;; wParam is a virtual key code (let ([id (hash-ref win32->symbol wParam #f)] [override-mapping? (and control-down? (not alt-down?))] @@ -210,7 +214,7 @@ [(and (not id) is-up?) (values (try-generate-release) #f #f #f)] [else - (values id #f #f #f)]))))]) + (values id #f #f #f)])))])]) (and id (if just-check? #t diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 061e3357..2bf69050 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -172,6 +172,16 @@ result)] [(= msg WM_CHAR) (do-key w msg wParam lParam #t #f default)] + [(= msg WM_MOUSEWHEEL) + (let ([orig-delta (quotient (HIWORD wParam) WHEEL_DELTA)]) + (let loop ([delta (abs orig-delta)]) + (unless (zero? delta) + (do-key w msg (if (negative? orig-delta) + 'wheel-down + 'wheel-up) + lParam #f #f void) + (loop (sub1 delta))))) + 0] [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] [wx (any-hwnd->wx control-hwnd)] From 2d216179e5936b9863045a331ae65efc0d305d8c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 10 Dec 2010 09:01:13 -0600 Subject: [PATCH 443/462] adjust meta-backspace and meta-delete so that they both delete whole words, with backspace getting rid of the one before the insertion point and delete getting rid of the one after the insertion point original commit: ac8fd51bc4c8fea7889e170da9653994d51ef30a --- collects/framework/private/keymap.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index e6e298fd..905f311a 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -1230,7 +1230,8 @@ (map "del" "delete-key") (map-meta "d" "kill-word") - (map-meta "del" "backward-kill-word") + (map-meta "del" "kill-word") + (map-meta "backspace" "backward-kill-word") (map-meta "c" "capitalize-word") (map-meta "u" "upcase-word") (map-meta "l" "downcase-word") From fdf79692b3c97804c9245a33b0e65baf137ebc2d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 10 Dec 2010 11:12:48 -0600 Subject: [PATCH 444/462] set the font for the flashing 'P' to be the small-control-font original commit: 32851bddf94653f271a6ff912a9e32213c05824f --- collects/framework/private/frame.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 4fb8cdae..21b1e5ce 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -2486,6 +2486,7 @@ (super-new [stretchable-width #f] [style '(transparent)]) + (send (get-dc) set-font small-control-font) (define-values (indicator-width indicator-height) (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) (values tw th))) From 2468f25c33a9ce8a4d24d217820bb731b1232600 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 7 Dec 2010 11:05:10 -0600 Subject: [PATCH 445/462] Adds support for inserting more arrow characters by their LaTex names original commit: a12491bb89030eda9635e0a1925dd60c8ea6d668 --- collects/mrlib/tex-table.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mrlib/tex-table.rkt b/collects/mrlib/tex-table.rkt index 25c0f9d6..5d5c65a3 100644 --- a/collects/mrlib/tex-table.rkt +++ b/collects/mrlib/tex-table.rkt @@ -28,15 +28,15 @@ ("leftrightarrow" "↔") ("nearrow" "↗") ("Updownarrow" "⇕") - + ("hookleftarrow" "↩") + ("hookrightarrow" "↪") + ("leadsto""↝") + ;; arrows that didn't come out right in copy & paste ;←− \longleftarrow ;⇐= \Longleftarrow - ;← 􏰂 \hookleftarrow ;←→ \longleftrightarrow - ;􏰁 → \hookrightarrow ;⇐⇒ \Longleftrightarrow - ;􏴲 \leadsto∗ ;􏰃−→ \longmapsto ;=⇒ \Longrightarrow ;􏰃→ \mapsto From 83ad612c98a4037ceac4cf2d48061eef082534ce Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 7 Dec 2010 11:11:14 -0600 Subject: [PATCH 446/462] Fixes the semi-automated TeX table test original commit: e65598c98c04ad1d2431ffbf0a65b360a171a9cb --- collects/mrlib/tex-table.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mrlib/tex-table.rkt b/collects/mrlib/tex-table.rkt index 5d5c65a3..1242bd79 100644 --- a/collects/mrlib/tex-table.rkt +++ b/collects/mrlib/tex-table.rkt @@ -181,14 +181,14 @@ ;; checks to see if there are duplicates #; (define (find-dups) - (let ([ht (make-hash-table 'equal)]) + (let ([ht (make-hash)]) (for-each (λ (line) (let ([name (list-ref line 0)] [obj (list-ref line 1)]) - (hash-table-put! ht name (cons obj (hash-table-get ht name '()))))) + (hash-set! ht name (cons obj (hash-ref ht name '()))))) tex-shortcut-table) - (hash-table-for-each + (hash-for-each ht (λ (k v) (unless (= 1 (length v)) From 77b082f08f86edf0a04e32e8d1396b171b07094a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Dec 2010 14:17:08 -0700 Subject: [PATCH 447/462] extend `sync/timeout' to allow a tail-position fail thunk for polling original commit: 2b4f1a69085fe9b9c41b1342bcbffd6bcafc88eb --- collects/mred/private/wx/common/queue.rkt | 28 ++++++++++++----------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 14c8006b..010211ef 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -399,20 +399,22 @@ [(and (eq? evt 'wait) (not handler?)) #t] - ;; `yield' is supposed to return immediately if the - ;; event is already ready: - [(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v))))) - => (lambda (v) (car v))] - [handler? - (sync (if (eq? evt 'wait) - (wrap-evt e (lambda (_) #t)) - evt) - (handle-evt ((eventspace-queue-proc e)) - (lambda (v) - (when v (handle-event v)) - (yield evt))))] [else - (sync evt)]))])) + (define (wait-now) + (if handler? + (sync (if (eq? evt 'wait) + (wrap-evt e (lambda (_) #t)) + evt) + (handle-evt ((eventspace-queue-proc e)) + (lambda (v) + (when v (handle-event v)) + (yield evt)))) + (sync evt))) + (if (evt? evt) + ;; `yield' is supposed to return immediately if the + ;; event is already ready: + (sync/timeout wait-now evt) + (wait-now))]))])) (define yield-refresh (lambda () From 313fe0d34c57b5af6451435206bb400ce5c63f94 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Dec 2010 18:51:53 -0700 Subject: [PATCH 448/462] win32: sync display on event original commit: b2444e210506a1c1b1e2e50d4640f6fa79180784 --- collects/mred/private/wx/win32/window.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 2bf69050..71e6ac5d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -650,11 +650,11 @@ (define/private (pre-event-refresh key?) ;; Since we break the connection between the - ;; Cocoa queue and event handling, we + ;; Win32 queue and event handling, we ;; re-sync the display in case a stream of ;; events (e.g., key repeat) have a corresponding ;; stream of screen updates. - (void)) + (flush-display)) (define/public (get-dialog-level) (send parent get-dialog-level))) From d4ffb4f39f33798caa9b2bcad14d2d645731d2e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Dec 2010 20:35:45 -0700 Subject: [PATCH 449/462] fix `get-char-height' and `get-char-width' in dc<%> Closes PR 11526 original commit: 965e8f96d13d26cf34c9c5a42a7e27c29eeea989 --- collects/tests/gracket/dc.rktl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index afce8bc4..7213989f 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -72,6 +72,9 @@ (try-ok 'set-text-foreground (make-object color% "Yellow")) (try-ok 'set-text-mode 'transparent) + (try-ok 'get-char-height) + (try-ok 'get-char-width) + (try 'try-color (make-object color% "Yellow") (make-object color%))) (st #f mdc ok?) From a0d21c5c08a49fdf85052d8bb6d08cb884cc8f9f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sat, 11 Dec 2010 01:16:30 -0600 Subject: [PATCH 450/462] Revert "Adds support for inserting more arrow characters by their LaTex names" This reverts commit a12491bb89030eda9635e0a1925dd60c8ea6d668, in which the documentation won't build as PDF. original commit: f293ace98d41150d8df1b3adc1be1de8d7ad5f13 --- collects/mrlib/tex-table.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mrlib/tex-table.rkt b/collects/mrlib/tex-table.rkt index 1242bd79..88a021bf 100644 --- a/collects/mrlib/tex-table.rkt +++ b/collects/mrlib/tex-table.rkt @@ -28,15 +28,15 @@ ("leftrightarrow" "↔") ("nearrow" "↗") ("Updownarrow" "⇕") - ("hookleftarrow" "↩") - ("hookrightarrow" "↪") - ("leadsto""↝") - + ;; arrows that didn't come out right in copy & paste ;←− \longleftarrow ;⇐= \Longleftarrow + ;← 􏰂 \hookleftarrow ;←→ \longleftrightarrow + ;􏰁 → \hookrightarrow ;⇐⇒ \Longleftrightarrow + ;􏴲 \leadsto∗ ;􏰃−→ \longmapsto ;=⇒ \Longrightarrow ;􏰃→ \mapsto From b80ef376308cb3329074a8df2c490bb4accaeb4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Dec 2010 19:57:05 -0700 Subject: [PATCH 451/462] win32: avoid continued failure when painting fails original commit: a5c4863848279b205411aa8ce2400ff02afc3a32 --- collects/mred/private/wx/win32/canvas.rkt | 35 ++++++++++++----------- collects/mred/private/wx/win32/window.rkt | 2 -- 2 files changed, 18 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index cfaf727a..92e3c78b 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -155,23 +155,24 @@ [(= msg WM_PAINT) (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) - (if for-gl? - (queue-paint) - (if (positive? paint-suspended) - (set! suspended-refresh? #t) - (let* ([hbrush (if no-autoclear? - #f - (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref)))]) - (when hbrush - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush))) - (unless (do-canvas-backing-flush hdc) - (queue-paint))))) - (EndPaint hdc ps)) + (when hdc + (if for-gl? + (queue-paint) + (if (positive? paint-suspended) + (set! suspended-refresh? #t) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-canvas-backing-flush hdc) + (queue-paint))))) + (EndPaint hdc ps))) 0] [(= msg WM_NCPAINT) (if control-border-theme diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 71e6ac5d..8f5086bc 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -56,8 +56,6 @@ -> (unless r (failed 'ClientToScreen)))) (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) -(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) - -> (when (zero? r) (failed 'FillRect)))) (define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void)) From ac66dd12d776d444473df91969d4554d58cfdf83 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Dec 2010 07:50:43 -0700 Subject: [PATCH 452/462] win32: fix alternate-key lookup Closes PR 11527 original commit: c7b4e5f1344a9f4940883a2b1a63b4a83bba9c89 --- collects/mred/private/wx/win32/key.rkt | 64 +++++++++++++++-------- collects/mred/private/wx/win32/window.rkt | 3 ++ 2 files changed, 44 insertions(+), 23 deletions(-) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index fd14fc19..fefc4603 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -8,7 +8,8 @@ (provide (protect-out make-key-event - generates-key-event?)) + generates-key-event? + reset-key-mapping)) (define-user32 GetKeyState (_wfun _int -> _SHORT)) (define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) @@ -34,15 +35,24 @@ ;; The characters in find_shift_alts are things that we'll try ;; to include in keyboard events as char-if-Shift-weren't-pressed, ;; char-if-AltGr-weren't-pressed, etc. -(define other-key-codes - (let ([find_shift_alts (string-append - "!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`" - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "0123456789")]) - (list->vector - (for/list ([i (in-string find_shift_alts)]) - (VkKeyScanW (char->integer i)))))) +(define find_shift_alts (string-append + "!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789")) +(define other-key-codes #f) +(define (get-other-key-codes) + (or other-key-codes + (begin + (set! other-key-codes + (list->vector + (for/list ([i (in-string find_shift_alts)]) + (VkKeyScanW (char->integer i))))) + other-key-codes))) +(define (reset-key-mapping) + (set! other-key-codes #f)) +(define (other-orig j) + (char->integer (string-ref find_shift_alts j))) ;; If a virtual key code has no mapping here, then the key should be ;; ignored by WM_KEYDOWN and processed by WM_CHAR instead @@ -136,26 +146,26 @@ (let ([k (MapVirtualKeyW sc 1)]) (if (zero? k) (values (integer->char id) #f #f #f) - (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector (get-other-key-codes))] [j (in-naturals)]) (if (= (bitwise-and o #xFF) k) ;; Figure out whether it's different in the shift ;; for AltGr dimension, or both: (if (eq? (zero? (bitwise-and o #x100)) shift-down?) ;; different Shift - (if (eq? (= (bitwise-and o #x600) #x6000) + (if (eq? (= (bitwise-and o #x600) #x600) (and control-down? alt-down?)) ;; same AltGr - (values id o a sa) + (values id (other-orig j) a sa) ;; different AltGr - (values id s a o)) + (values id s a (other-orig j))) ;; same Shift - (if (eq? (= (bitwise-and o #x600) #x6000) + (if (eq? (= (bitwise-and o #x600) #x600) (and control-down? alt-down?)) ;; same AltGr (values id s a sa) ;; different AltGr - (values id s o sa))) + (values id s (other-orig j) sa))) (values id s a sa))))))] [else ;; wParam is a virtual key code @@ -184,15 +194,15 @@ [else id])]) (let-values ([(s a sa) ;; Look for shifted alternate: - (for/fold ([s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + (for/fold ([s #f][a #f][sa #f]) ([o (in-vector (get-other-key-codes))] [j (in-naturals)]) (if (= (bitwise-and o #xFF) wParam) (if (not (zero? (bitwise-and o #x100))) - (if (= (bitwise-and o #x600) #x6000) - (values s a o) - (values o a sa)) - (if (= (bitwise-and o #x600) #x6000) - (values s o sa) + (if (= (bitwise-and o #x600) #x600) + (values s a (other-orig j)) + (values (other-orig j) a sa)) + (if (= (bitwise-and o #x600) #x600) + (values s (other-orig j) sa) (values s a sa))) (values s a sa)))]) (if (and id shift-down?) @@ -233,8 +243,16 @@ [x 0] [y 0] [time-stamp 0] - [caps-down caps-down?])]) + [caps-down caps-down?])] + [as-key (lambda (v) + (if (integer? v) (integer->char v) v))]) (when is-up? (send e set-key-release-code key-id)) + (when other-shift + (send e set-other-shift-key-code (as-key other-shift))) + (when other-altgr + (send e set-other-altgr-key-code (as-key other-altgr))) + (when other-shift-altgr + (send e set-other-shift-altgr-key-code (as-key other-shift-altgr))) e)))))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 8f5086bc..d89efe44 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -220,6 +220,9 @@ [(= msg WM_COPYDATA) (handle-copydata lParam) 0] + [(= msg WM_INPUTLANGCHANGE) + (reset-key-mapping) + 0] [else (default w msg wParam lParam)]))) From 514d0d2175cc2778bd24137131ebc34537323a02 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Dec 2010 21:23:09 -0700 Subject: [PATCH 453/462] win32: show #t brings shown frame to front Closes PR 11533 original commit: acdd76b17e89061a1a846c6810bfd9d10938278b --- collects/mred/private/wx/win32/frame.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 0c42e5d0..5ebf30e6 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -25,6 +25,7 @@ (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) (define-user32 GetActiveWindow (_wfun -> _HWND)) (define-user32 SetFocus (_wfun _HWND -> _HWND)) +(define-user32 BringWindowToTop (_wfun _HWND -> (r : _BOOL) -> (unless r (failed 'BringWindowToTop)))) (define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) @@ -141,6 +142,8 @@ (define saved-title (or label "")) (define hidden-zoomed? #f) + (define float-without-caption? (and (memq 'float style) + (memq 'no-caption style))) (define min-width #f) (define min-height #f) @@ -187,9 +190,14 @@ (set! hidden-zoomed? (is-maximized?))) (super direct-show on? (if hidden-zoomed? SW_SHOWMAXIMIZED - SW_SHOW)) + (if float-without-caption? + SW_SHOWNOACTIVATE + SW_SHOW))) (when (and on? (iconized?)) - (ShowWindow hwnd SW_RESTORE))) + (ShowWindow hwnd SW_RESTORE)) + (when on? + (unless float-without-caption? + (BringWindowToTop hwnd)))) (define/public (destroy) (direct-show #f)) From f8d191077879ad0902e612d2d333117568fabd2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Dec 2010 20:38:38 -0700 Subject: [PATCH 454/462] cocoa: add app badge to caution & stop icons original commit: 953dd78d764ab873bc8653dfab24ef84c516defc --- collects/mred/private/wx/cocoa/message.rkt | 55 ++++++++++++++++------ 1 file changed, 40 insertions(+), 15 deletions(-) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index bd9ef2a0..d8f0bdc0 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -4,6 +4,7 @@ ffi/unsafe/objc racket/draw/private/bitmap "../../syntax.rkt" + "../../lock.rkt" "window.rkt" "item.rkt" "utils.rkt" @@ -30,6 +31,43 @@ #:type _NSString "NSApplicationPath"))) +(define (make-icon label) + (let ([icon + (if (eq? label 'app) + (get-app-icon) + (let ([id (integer-bytes->integer + (case label + [(caution) #"caut"] + [(stop) #"stop"]) + #f + #t)]) + (tell (tell NSWorkspace sharedWorkspace) + iconForFileType: + (NSFileTypeForHFSTypeCode id))))]) + (tellv icon retain) + (tellv icon setSize: #:type _NSSize (make-NSSize 64 64)) + (unless (eq? label 'app) + ;; Add badge: + (let ([app-icon (get-icon 'app)]) + (tellv icon lockFocus) + (tellv app-icon drawInRect: #:type _NSRect (make-NSRect (make-NSPoint 32 0) + (make-NSSize 32 32)) + fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize 64 64)) + operation: #:type _int 2 ; NSCompositeSourceOver + fraction: #:type _CGFloat 1.0) + (tellv icon unlockFocus))) + icon)) + +(define icons (make-hash)) +(define (get-icon label) + (or (hash-ref icons label #f) + (let ([icon (atomically (make-icon label))]) + (hash-set! icons label icon) + icon))) + +;; ---------------------------------------- + (define-objc-class MyTextField NSTextField #:mixins (KeyMouseResponder CursorDisplayer) [wxb]) @@ -47,21 +85,7 @@ (super-new [parent parent] [cocoa (let* ([label (cond [(string? label) label] - [(symbol? label) - (let ([icon - (if (eq? label 'app) - (get-app-icon) - (let ([id (integer-bytes->integer - (case label - [(caution) #"caut"] - [(stop) #"stop"]) - #f - #t)]) - (tell (tell NSWorkspace sharedWorkspace) - iconForFileType: - (NSFileTypeForHFSTypeCode id))))]) - (tellv icon setSize: #:type _NSSize (make-NSSize 64 64)) - icon)] + [(symbol? label) (get-icon label)] [(send label ok?) label] [else ""])] [cocoa @@ -103,3 +127,4 @@ (define/override (gets-focus?) #f) (def/public-unimplemented get-font)) + From 4efe81afff281f8af9a169ad4855b1eb1e3f8154 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Dec 2010 21:03:56 -0700 Subject: [PATCH 455/462] win64: HIWORD and LOWORD signs original commit: aa43ba40c72a6f499ff4f4729c787b2975bd29b9 --- collects/mred/private/wx/win32/types.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 22919929..288dfa4b 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -127,10 +127,15 @@ [time _DWORD] [pt _POINT])) +(define (short v) + (if (zero? (bitwise-and #x8000 v)) + v + (bitwise-ior v (arithmetic-shift -1 15)))) + (define (HIWORD v) - (arithmetic-shift v -16)) + (short (arithmetic-shift v -16))) (define (LOWORD v) - (bitwise-and v #xFFFF)) + (short (bitwise-and v #xFFFF))) (define (MAKELONG a b) (bitwise-ior (arithmetic-shift b 16) From 908ece5030a767e631de2268baaa2a8e74de0e2d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Nov 2010 07:43:18 -0600 Subject: [PATCH 456/462] change 2htdp/image to try to improve the way drawing works when there is sharing the in the tree original commit: 9ce75b8f76d607237659c3c457f6ceb52752c64b --- collects/mrlib/image-core.rkt | 321 +++++++++++++++++++++++++++------- 1 file changed, 253 insertions(+), 68 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index e9d4684d..5374d93e 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -36,7 +36,9 @@ has been moved out). "private/image-core-snipclass.rkt" "private/regmk.rkt" (prefix-in cis: "cache-image-snip.ss") - (for-syntax racket/base)) + (for-syntax racket/base) + data/queue + "private/heap.rkt") @@ -576,9 +578,33 @@ has been moved out). [(is-a? image image-snip%) (send dc draw-bitmap (send image get-bitmap) dx dy)] [else + + #; + (let () + (define s (send image get-shape)) + (define (conv ht [val? #t]) + (sort (hash-map ht (λ (k v) (list (eq-hash-code k) v))) + < + #:key (if val? car cadr))) + (let ([times-drawn (find-times-drawn s)] + [steps-to-draw (find-steps-to-draw s)]) + (printf "times drawn ~s\n" (conv times-drawn)) + (printf "steps to draw ~s\n" (conv steps-to-draw)) + (let ([product (make-hasheq)]) + (hash-for-each + steps-to-draw + (λ (k v) + (when (> (hash-ref times-drawn k) 1) + (hash-set! product k (* v (hash-ref times-drawn k)))))) + (printf "product ~s\n" (conv product #f))) + (exit))) + (if (render-normalized) (render-normalized-shape (send image get-normalized-shape) dc dx dy) - (render-arbitrary-shape (send image get-shape) dc dx dy)) + (render-arbitrary-shape (send image get-shape) + (bb-right (send image get-bb)) + (bb-bottom (send image get-bb)) + dc dx dy)) (let ([ph (send image get-pinhole)]) (when ph (let* ([px (point-x ph)] @@ -603,6 +629,145 @@ has been moved out). (send dc set-smoothing smoothing) (send dc set-alpha alpha))) +(define (find-times-drawn shape) + (define ht (make-hasheq)) + (define visited (make-hasheq)) + (define parent-ht (make-hasheq)) + (define children-ht (make-hasheq)) + (define (add-child c p) + (hash-set! parent-ht p (cons c (hash-ref parent-ht p '()))) + (hash-set! children-ht c (cons p (hash-ref children-ht c '())))) + + (hash-set! parent-ht shape '()) + + ;; build the parent->child mapping + (let loop ([shape shape]) + (unless (hash-ref visited shape #f) + + ;; make sure there is an entry in each table for each shape + (hash-set! parent-ht shape (hash-ref parent-ht shape '())) + (hash-set! children-ht shape (hash-ref children-ht shape '())) + + (hash-set! visited shape #t) + (cond + [(translate? shape) + (add-child (translate-shape shape) shape) + (loop (translate-shape shape))] + [(scale? shape) + (add-child (scale-shape shape) shape) + (loop (scale-shape shape))] + [(overlay? shape) + (add-child (overlay-bottom shape) shape) + (add-child (overlay-top shape) shape) + (loop (overlay-bottom shape)) + (loop (overlay-top shape))] + [(crop? shape) + (add-child (crop-shape shape) shape) + (loop (crop-shape shape))] + [else (void)]))) + + (define heap (make-heap)) + + (hash-for-each + parent-ht + (λ (n parents) + (heap-insert! heap n (length parents)))) + + (define ordered-nodes '()) + (let loop () + (unless (heap-empty? heap) + (define min (heap-remove-min! heap)) + (for ([child (in-list (hash-ref children-ht min))]) + (heap-decrease-key! heap child)) + (set! ordered-nodes (cons min ordered-nodes)) + (loop))) + + (let () + (define port (open-output-file "ex.dot" #:exists 'truncate)) + (define ht (make-hasheq)) + (define q (make-queue)) + (define (enq a b) + (fprintf port " ~a -> ~a\n" + (eq-hash-code a) + (eq-hash-code b)) + (enqueue! q (list a b))) + (fprintf port "digraph {\n") + (enqueue! q (list #f shape)) + (let loop () + (unless (queue-empty? q) + (define-values (from to) (apply values (dequeue! q))) + (define to-already-visited? (hash-ref ht to #f)) + (define (cut str) (substring str 0 (min (string-length str) 20))) + (cond + [(not from) + (hash-set! ht to 1)] + [else + (hash-set! ht to (+ (hash-ref ht from) (hash-ref ht to 0)))]) + (unless to-already-visited? + (cond + [(translate? to) + (enq to (translate-shape to))] + [(scale? to) + (enq to (scale-shape to))] + [(overlay? to) + (enq to (overlay-bottom to)) + (enq to (overlay-top to))] + [(crop? to) + (enq to (crop-shape to))] + [else + (void)])) + (loop))) + + (hash-for-each + ht + (λ (a v) + (fprintf port + " ~a [label=\"~a ~a\"]\n" + (eq-hash-code a) + (eq-hash-code a) + (cond + [(translate? a) 'translate] + [(scale? a) 'scale] + [(overlay? a) 'overlay] + [(crop? a) 'crop] + [(polygon? a) + (if (regexp-match #rx"red" (format "~s" a)) + 'red-polygon + 'polygon)])))) + (fprintf port "}\n") + (close-output-port port)) + + (hash-set! ht (car ordered-nodes) 1) + (for ([node (in-list (cdr ordered-nodes))]) + (hash-set! ht node (apply + (map (λ (x) (hash-ref ht x)) + (hash-ref children-ht node))))) + + ht) + +(define (find-steps-to-draw shape) + (define ht (make-hasheq)) + (let loop ([shape shape]) + (cond + [(hash-ref ht shape #f) + => + values] + [else + (define res + (cond + [(translate? shape) + (+ (loop (translate-shape shape)) 1)] + [(scale? shape) + (+ (loop (scale-shape shape)) 1)] + [(overlay? shape) + (+ (loop (overlay-bottom shape)) + (loop (overlay-top shape)))] + [(crop? shape) + (+ (loop (crop-shape shape)) 1)] + [else 1])) + (hash-set! ht shape res) + res])) + ht) + (define (save-image-as-bitmap image filename kind) (let* ([bb (send image get-bb)] [bm (make-object bitmap% @@ -642,9 +807,10 @@ has been moved out). (send new-region set-path path dx dy) (when old-region (send new-region intersect old-region)) (send dc set-clipping-region new-region) - (parameterize ([last-cropped-points points]) - (continue inner-shape)) - (send dc set-clipping-region old-region))])) + (begin0 + (parameterize ([last-cropped-points points]) + (continue inner-shape)) + (send dc set-clipping-region old-region)))])) (define (render-simple-shape simple-shape dc dx dy) (cond @@ -658,69 +824,88 @@ has been moved out). [else (render-poly/line-segment/curve-segment simple-shape dc dx dy)])) -(define (render-arbitrary-shape shape dc dx dy) - (let loop ([shape shape] - [dx dx] - [dy dy] - [x-scale 1] - [y-scale 1]) - (define (scale-point p) - (make-point (* x-scale (point-x p)) - (* y-scale (point-y p)))) - (cond - [(translate? shape) - (loop (translate-shape shape) - (+ dx (* x-scale (translate-dx shape))) - (+ dy (* y-scale (translate-dy shape))) - x-scale - y-scale)] - [(scale? shape) - (loop (scale-shape shape) - dx - dy - (* x-scale (scale-x shape)) - (* y-scale (scale-y shape)))] - [(overlay? shape) - (loop (overlay-bottom shape) dx dy x-scale y-scale) - (loop (overlay-top shape) dx dy x-scale y-scale)] - [(crop? shape) - (render-cropped-shape - (map scale-point (crop-points shape)) - (crop-shape shape) - (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] - [(polygon? shape) - (let* ([this-one - (make-polygon (map scale-point (polygon-points shape)) - (polygon-mode shape) - (scale-color (polygon-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy))] - [(line-segment? shape) - (let ([this-one - (make-line-segment (scale-point (line-segment-start shape)) - (scale-point (line-segment-end shape)) - (scale-color (line-segment-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy))] - [(curve-segment? shape) - ;; the pull is multiplied by the distance - ;; between the two points when it is drawn, - ;; so we don't need to scale it here - (let ([this-one - (make-curve-segment (scale-point (curve-segment-start shape)) - (curve-segment-s-angle shape) - (curve-segment-s-pull shape) - (scale-point (curve-segment-end shape)) - (curve-segment-e-angle shape) - (curve-segment-e-pull shape) - (scale-color (curve-segment-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy))] - [(or (ibitmap? shape) (np-atomic-shape? shape)) - (let* ([shape (if (ibitmap? shape) - (make-flip #f shape) - shape)] - [this-one (scale-np-atomic x-scale y-scale shape)]) - (render-np-atomic-shape this-one dc dx dy))] - [else - (error 'normalize-shape "unknown shape ~s\n" shape)]))) +(define (render-arbitrary-shape shape w h dc dx dy) + (unless (or (zero? w) (zero? h)) + (define times-drawn-table (find-times-drawn shape)) + (define cache (make-hasheq)) + (let loop ([shape shape] + [dx 0] + [dy 0] + [x-scale 1] + [y-scale 1]) + (define (scale-point p) + (make-point (* x-scale (point-x p)) + (* y-scale (point-y p)))) + (define drawing-complexity + (cond + [(translate? shape) + (+ (loop (translate-shape shape) + (+ dx (* x-scale (translate-dx shape))) + (+ dy (* y-scale (translate-dy shape))) + x-scale + y-scale) + 1)] + [(scale? shape) + (loop (scale-shape shape) + dx + dy + (* x-scale (scale-x shape)) + (* y-scale (scale-y shape)))] + [(overlay? shape) + (+ (loop (overlay-bottom shape) dx dy x-scale y-scale) + (loop (overlay-top shape) dx dy x-scale y-scale))] + [(crop? shape) + (render-cropped-shape + (map scale-point (crop-points shape)) + (crop-shape shape) + (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] + [(polygon? shape) + (let* ([this-one + (make-polygon (map scale-point (polygon-points shape)) + (polygon-mode shape) + (scale-color (polygon-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy)) + 1] + [(line-segment? shape) + (let ([this-one + (make-line-segment (scale-point (line-segment-start shape)) + (scale-point (line-segment-end shape)) + (scale-color (line-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy)) + 1] + [(curve-segment? shape) + ;; the pull is multiplied by the distance + ;; between the two points when it is drawn, + ;; so we don't need to scale it here + (let ([this-one + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (scale-color (curve-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy)) + 1] + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let* ([shape (if (ibitmap? shape) + (make-flip #f shape) + shape)] + [this-one (scale-np-atomic x-scale y-scale shape)]) + (render-np-atomic-shape this-one dc dx dy)) + 1] + [else + (error 'render-arbitrary-shape "unknown shape ~s\n" shape)])) + + (define times-drawn (hash-ref times-drawn-table shape)) + (when (and (> times-drawn 1) + (> (* drawing-complexity times-drawn) 100)) + (printf "would have cached.... ~s\n" (* drawing-complexity times-drawn)) + ;; need to copy a region of the bitmap we've just created + ;; into a new bitmap and save that in the cache table, + ;; but we don't know what that region is (ugh). + (void)) + drawing-complexity))) (define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) From 590b3c2747786fd1962e6b6826acc40001576300 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 12 Dec 2010 15:13:24 -0600 Subject: [PATCH 457/462] finally, a fix that makes the 2htdp/image test suite pass! original commit: 91aa9f756a258a8b9de624024fe81c4864f1b1dd --- collects/mrlib/image-core.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 5374d93e..8d96f49a 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -977,6 +977,7 @@ has been moved out). (send dc draw-path path dx dy)))] [(flip? np-atomic-shape) (let ([bm (get-rendered-bitmap np-atomic-shape)]) + (send dc set-smoothing 'smoothed) (send dc draw-bitmap bm (- dx (/ (send bm get-width) 2)) @@ -988,6 +989,7 @@ has been moved out). (let ([θ (degrees->radians (text-angle np-atomic-shape))] [font (send dc get-font)]) (send dc set-font (text->font np-atomic-shape)) + (send dc set-smoothing 'aligned) ;; should this be smoothed? (let ([color (get-color-arg (text-color np-atomic-shape))]) (send dc set-text-foreground (cond From a0d80c60388786edea5ded0c56ed54a2aae3d53b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 12 Dec 2010 15:18:06 -0600 Subject: [PATCH 458/462] Revert "change 2htdp/image to try to improve the way drawing works when there is sharing the in the tree" This reverts commit 9ce75b8f76d607237659c3c457f6ceb52752c64b. original commit: 8add8cfdf596c5ea833b3a83e4b2d7df550ad218 --- collects/mrlib/image-core.rkt | 321 +++++++--------------------------- 1 file changed, 68 insertions(+), 253 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 8d96f49a..bab19783 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -36,9 +36,7 @@ has been moved out). "private/image-core-snipclass.rkt" "private/regmk.rkt" (prefix-in cis: "cache-image-snip.ss") - (for-syntax racket/base) - data/queue - "private/heap.rkt") + (for-syntax racket/base)) @@ -578,33 +576,9 @@ has been moved out). [(is-a? image image-snip%) (send dc draw-bitmap (send image get-bitmap) dx dy)] [else - - #; - (let () - (define s (send image get-shape)) - (define (conv ht [val? #t]) - (sort (hash-map ht (λ (k v) (list (eq-hash-code k) v))) - < - #:key (if val? car cadr))) - (let ([times-drawn (find-times-drawn s)] - [steps-to-draw (find-steps-to-draw s)]) - (printf "times drawn ~s\n" (conv times-drawn)) - (printf "steps to draw ~s\n" (conv steps-to-draw)) - (let ([product (make-hasheq)]) - (hash-for-each - steps-to-draw - (λ (k v) - (when (> (hash-ref times-drawn k) 1) - (hash-set! product k (* v (hash-ref times-drawn k)))))) - (printf "product ~s\n" (conv product #f))) - (exit))) - (if (render-normalized) (render-normalized-shape (send image get-normalized-shape) dc dx dy) - (render-arbitrary-shape (send image get-shape) - (bb-right (send image get-bb)) - (bb-bottom (send image get-bb)) - dc dx dy)) + (render-arbitrary-shape (send image get-shape) dc dx dy)) (let ([ph (send image get-pinhole)]) (when ph (let* ([px (point-x ph)] @@ -629,145 +603,6 @@ has been moved out). (send dc set-smoothing smoothing) (send dc set-alpha alpha))) -(define (find-times-drawn shape) - (define ht (make-hasheq)) - (define visited (make-hasheq)) - (define parent-ht (make-hasheq)) - (define children-ht (make-hasheq)) - (define (add-child c p) - (hash-set! parent-ht p (cons c (hash-ref parent-ht p '()))) - (hash-set! children-ht c (cons p (hash-ref children-ht c '())))) - - (hash-set! parent-ht shape '()) - - ;; build the parent->child mapping - (let loop ([shape shape]) - (unless (hash-ref visited shape #f) - - ;; make sure there is an entry in each table for each shape - (hash-set! parent-ht shape (hash-ref parent-ht shape '())) - (hash-set! children-ht shape (hash-ref children-ht shape '())) - - (hash-set! visited shape #t) - (cond - [(translate? shape) - (add-child (translate-shape shape) shape) - (loop (translate-shape shape))] - [(scale? shape) - (add-child (scale-shape shape) shape) - (loop (scale-shape shape))] - [(overlay? shape) - (add-child (overlay-bottom shape) shape) - (add-child (overlay-top shape) shape) - (loop (overlay-bottom shape)) - (loop (overlay-top shape))] - [(crop? shape) - (add-child (crop-shape shape) shape) - (loop (crop-shape shape))] - [else (void)]))) - - (define heap (make-heap)) - - (hash-for-each - parent-ht - (λ (n parents) - (heap-insert! heap n (length parents)))) - - (define ordered-nodes '()) - (let loop () - (unless (heap-empty? heap) - (define min (heap-remove-min! heap)) - (for ([child (in-list (hash-ref children-ht min))]) - (heap-decrease-key! heap child)) - (set! ordered-nodes (cons min ordered-nodes)) - (loop))) - - (let () - (define port (open-output-file "ex.dot" #:exists 'truncate)) - (define ht (make-hasheq)) - (define q (make-queue)) - (define (enq a b) - (fprintf port " ~a -> ~a\n" - (eq-hash-code a) - (eq-hash-code b)) - (enqueue! q (list a b))) - (fprintf port "digraph {\n") - (enqueue! q (list #f shape)) - (let loop () - (unless (queue-empty? q) - (define-values (from to) (apply values (dequeue! q))) - (define to-already-visited? (hash-ref ht to #f)) - (define (cut str) (substring str 0 (min (string-length str) 20))) - (cond - [(not from) - (hash-set! ht to 1)] - [else - (hash-set! ht to (+ (hash-ref ht from) (hash-ref ht to 0)))]) - (unless to-already-visited? - (cond - [(translate? to) - (enq to (translate-shape to))] - [(scale? to) - (enq to (scale-shape to))] - [(overlay? to) - (enq to (overlay-bottom to)) - (enq to (overlay-top to))] - [(crop? to) - (enq to (crop-shape to))] - [else - (void)])) - (loop))) - - (hash-for-each - ht - (λ (a v) - (fprintf port - " ~a [label=\"~a ~a\"]\n" - (eq-hash-code a) - (eq-hash-code a) - (cond - [(translate? a) 'translate] - [(scale? a) 'scale] - [(overlay? a) 'overlay] - [(crop? a) 'crop] - [(polygon? a) - (if (regexp-match #rx"red" (format "~s" a)) - 'red-polygon - 'polygon)])))) - (fprintf port "}\n") - (close-output-port port)) - - (hash-set! ht (car ordered-nodes) 1) - (for ([node (in-list (cdr ordered-nodes))]) - (hash-set! ht node (apply + (map (λ (x) (hash-ref ht x)) - (hash-ref children-ht node))))) - - ht) - -(define (find-steps-to-draw shape) - (define ht (make-hasheq)) - (let loop ([shape shape]) - (cond - [(hash-ref ht shape #f) - => - values] - [else - (define res - (cond - [(translate? shape) - (+ (loop (translate-shape shape)) 1)] - [(scale? shape) - (+ (loop (scale-shape shape)) 1)] - [(overlay? shape) - (+ (loop (overlay-bottom shape)) - (loop (overlay-top shape)))] - [(crop? shape) - (+ (loop (crop-shape shape)) 1)] - [else 1])) - (hash-set! ht shape res) - res])) - ht) - (define (save-image-as-bitmap image filename kind) (let* ([bb (send image get-bb)] [bm (make-object bitmap% @@ -807,10 +642,9 @@ has been moved out). (send new-region set-path path dx dy) (when old-region (send new-region intersect old-region)) (send dc set-clipping-region new-region) - (begin0 - (parameterize ([last-cropped-points points]) - (continue inner-shape)) - (send dc set-clipping-region old-region)))])) + (parameterize ([last-cropped-points points]) + (continue inner-shape)) + (send dc set-clipping-region old-region))])) (define (render-simple-shape simple-shape dc dx dy) (cond @@ -824,88 +658,69 @@ has been moved out). [else (render-poly/line-segment/curve-segment simple-shape dc dx dy)])) -(define (render-arbitrary-shape shape w h dc dx dy) - (unless (or (zero? w) (zero? h)) - (define times-drawn-table (find-times-drawn shape)) - (define cache (make-hasheq)) - (let loop ([shape shape] - [dx 0] - [dy 0] - [x-scale 1] - [y-scale 1]) - (define (scale-point p) - (make-point (* x-scale (point-x p)) - (* y-scale (point-y p)))) - (define drawing-complexity - (cond - [(translate? shape) - (+ (loop (translate-shape shape) - (+ dx (* x-scale (translate-dx shape))) - (+ dy (* y-scale (translate-dy shape))) - x-scale - y-scale) - 1)] - [(scale? shape) - (loop (scale-shape shape) - dx - dy - (* x-scale (scale-x shape)) - (* y-scale (scale-y shape)))] - [(overlay? shape) - (+ (loop (overlay-bottom shape) dx dy x-scale y-scale) - (loop (overlay-top shape) dx dy x-scale y-scale))] - [(crop? shape) - (render-cropped-shape - (map scale-point (crop-points shape)) - (crop-shape shape) - (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] - [(polygon? shape) - (let* ([this-one - (make-polygon (map scale-point (polygon-points shape)) - (polygon-mode shape) - (scale-color (polygon-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy)) - 1] - [(line-segment? shape) - (let ([this-one - (make-line-segment (scale-point (line-segment-start shape)) - (scale-point (line-segment-end shape)) - (scale-color (line-segment-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy)) - 1] - [(curve-segment? shape) - ;; the pull is multiplied by the distance - ;; between the two points when it is drawn, - ;; so we don't need to scale it here - (let ([this-one - (make-curve-segment (scale-point (curve-segment-start shape)) - (curve-segment-s-angle shape) - (curve-segment-s-pull shape) - (scale-point (curve-segment-end shape)) - (curve-segment-e-angle shape) - (curve-segment-e-pull shape) - (scale-color (curve-segment-color shape) x-scale y-scale))]) - (render-poly/line-segment/curve-segment this-one dc dx dy)) - 1] - [(or (ibitmap? shape) (np-atomic-shape? shape)) - (let* ([shape (if (ibitmap? shape) - (make-flip #f shape) - shape)] - [this-one (scale-np-atomic x-scale y-scale shape)]) - (render-np-atomic-shape this-one dc dx dy)) - 1] - [else - (error 'render-arbitrary-shape "unknown shape ~s\n" shape)])) - - (define times-drawn (hash-ref times-drawn-table shape)) - (when (and (> times-drawn 1) - (> (* drawing-complexity times-drawn) 100)) - (printf "would have cached.... ~s\n" (* drawing-complexity times-drawn)) - ;; need to copy a region of the bitmap we've just created - ;; into a new bitmap and save that in the cache table, - ;; but we don't know what that region is (ugh). - (void)) - drawing-complexity))) +(define (render-arbitrary-shape shape dc dx dy) + (let loop ([shape shape] + [dx dx] + [dy dy] + [x-scale 1] + [y-scale 1]) + (define (scale-point p) + (make-point (* x-scale (point-x p)) + (* y-scale (point-y p)))) + (cond + [(translate? shape) + (loop (translate-shape shape) + (+ dx (* x-scale (translate-dx shape))) + (+ dy (* y-scale (translate-dy shape))) + x-scale + y-scale)] + [(scale? shape) + (loop (scale-shape shape) + dx + dy + (* x-scale (scale-x shape)) + (* y-scale (scale-y shape)))] + [(overlay? shape) + (loop (overlay-bottom shape) dx dy x-scale y-scale) + (loop (overlay-top shape) dx dy x-scale y-scale)] + [(crop? shape) + (render-cropped-shape + (map scale-point (crop-points shape)) + (crop-shape shape) + (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] + [(polygon? shape) + (let* ([this-one + (make-polygon (map scale-point (polygon-points shape)) + (polygon-mode shape) + (scale-color (polygon-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(line-segment? shape) + (let ([this-one + (make-line-segment (scale-point (line-segment-start shape)) + (scale-point (line-segment-end shape)) + (scale-color (line-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(curve-segment? shape) + ;; the pull is multiplied by the distance + ;; between the two points when it is drawn, + ;; so we don't need to scale it here + (let ([this-one + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (scale-color (curve-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let* ([shape (if (ibitmap? shape) + (make-flip #f shape) + shape)] + [this-one (scale-np-atomic x-scale y-scale shape)]) + (render-np-atomic-shape this-one dc dx dy))] + [else + (error 'normalize-shape "unknown shape ~s\n" shape)]))) (define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) From 48c66d396cea4a7fc73d000ed53d95e9148a8e9b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 10 Dec 2010 13:54:30 -0600 Subject: [PATCH 459/462] fix docs typo original commit: 7512986086cfaaded1abf025676f83fdd9b3e32b --- collects/framework/preferences.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 8f5fd3d0..591f2f40 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -405,7 +405,7 @@ the state transitions / contracts are: #:rewrite-aliases (listof (-> any/c any))) void?) ((symbol value test) - ((aliases '()) (rewrite-aliases (map (lambda (x) (values)) aliases)))) + ((aliases '()) (rewrite-aliases (map (lambda (x) values) aliases)))) @{This function must be called every time your application starts up, before any call to @scheme[preferences:get] or @scheme[preferences:set] (for any given preference). From ba3e1697fbaba2efefa0016ee6e172ae9ffbb481 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 10 Dec 2010 20:55:40 -0600 Subject: [PATCH 460/462] added a pointer to the serialization functions from the preferences marshalling and unmarshalling original commit: 4391de9ba6cd7596e02fae09410c37a9b579ff05 --- collects/framework/preferences.rkt | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 591f2f40..ce875d51 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -29,7 +29,7 @@ the state transitions / contracts are: (require scribble/srcdoc scheme/class scheme/gui/base scheme/contract scheme/file) -(require/doc scheme/base scribble/manual) +(require/doc scheme/base scribble/manual (for-label racket/serialize)) (provide exn:struct:unknown-preference) @@ -434,13 +434,13 @@ the state transitions / contracts are: preferences:set-un/marshall (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?) (symbol marshall unmarshall) - @{@scheme[preference:set-un/marshall] is used to specify marshalling and + @{@scheme[preferences:set-un/marshall] is used to specify marshalling and unmarshalling functions for the preference @scheme[symbol]. @scheme[marshall] will be called when the users saves their preferences to turn the preference value for @scheme[symbol] into a printable value. @scheme[unmarshall] will be called when the user's preferences are read from the file to transform the printable value - into its internal representation. If @scheme[preference:set-un/marshall] + into its internal representation. If @scheme[preferences:set-un/marshall] is never called for a particular preference, the values of that preference are assumed to be printable. @@ -454,8 +454,11 @@ the state transitions / contracts are: happen when the preferences file becomes corrupted, or is edited by hand. - @scheme[preference:set-un/marshall] must be called before calling - @scheme[preferences:get],@scheme[preferences:set].}) + @scheme[preferences:set-un/marshall] must be called before calling + @scheme[preferences:get],@scheme[preferences:set]. + + See also @racket[serialize] and @racket[deserialize]. + }) (proc-doc/names preferences:restore-defaults From 7e7a86c3ceef0ce3bcc7fc061179a360e7a87d8c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 11 Dec 2010 20:48:13 -0600 Subject: [PATCH 461/462] only show the compiling messages when PLTDRCM is trace original commit: 3424e1b1df543c6a7f27640734d6fdf6ff71b4ff --- collects/framework/splash.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 3edea6e3..016b149a 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -220,7 +220,9 @@ (equal? (getenv "PLTDRDEBUG") "trace")) (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") (manager-trace-handler - (λ (x) (display "2: ") (display x) (newline)))))) + (λ (x) + (when (regexp-match #rx"compiling" x) + (display "2: ") (display x) (newline))))))) (define funny-gauge% (class canvas% From 3ef842d86857c574ba7e71cc5cd2e50057da1666 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 12 Dec 2010 08:16:53 -0600 Subject: [PATCH 462/462] added a note about how label-string? is used. original commit: 8101c03d308b2a0ff747e01cbdfcef0e37f34d88 --- collects/scribblings/gui/miscwin-funcs.scrbl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index dcc9cdb0..99c4335e 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -372,7 +372,15 @@ See @racket[clipboard<%>]. } @defproc[(label-string? [v any/c]) boolean?]{ - Returns @racket[#t] if @racket[v] is a string whose length is less than or equal to @racket[200]. + Returns @racket[#t] if @racket[v] is a string whose length is less than or equal to @racket[200]. + + This predicate is typically used as the contract for strings that + appear in GUI objects. In some cases, such as the label in a @racket[button%] + or @racket[menu-item%] object, the character @litchar{&} is treated specially + to indicate that the following character is used in keyboard navigation. See + @xmethod[labelled-menu-item<%> set-label] for one such example. + In other cases, such as the label on a @racket[frame%], @litchar{&} is not + treated specially. } @defproc[(key-code-symbol? [v any/c]) boolean?]{