From 5d1df3d05db25f891909efacf277d115817b9d38 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 2 Feb 2011 16:05:59 -0600 Subject: [PATCH 01/29] missed a multiple-vlaues change in a short-cut case. Please merge to the 5.1 release branch original commit: 63aa388d495fc753c9772cc645e32672a841cc89 --- collects/framework/private/color.rkt | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index a1203f8f..365c48f0 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -825,20 +825,23 @@ added get-regions (define/public (get-token-range position) (define-values (tokens ls) (get-tokens-at-position 'get-token-range position)) - (values (and tokens (+ (lexer-state-start-pos ls) - (send tokens get-root-start-position))) - (and tokens (+ (lexer-state-start-pos ls) - (send tokens get-root-end-position))))) + (values (and tokens ls + (+ (lexer-state-start-pos ls) + (send tokens get-root-start-position))) + (and tokens ls + (+ (lexer-state-start-pos ls) + (send tokens get-root-end-position))))) (define/private (get-tokens-at-position who position) (when stopped? (error who "called on a color:text<%> whose colorer is stopped.")) (let ([ls (find-ls position)]) - (and ls - (let ([tokens (lexer-state-tokens ls)]) + (if ls + (let ([tokens (lexer-state-tokens ls)]) (tokenize-to-pos ls position) (send tokens search! (- position (lexer-state-start-pos ls))) - (values tokens ls))))) + (values tokens ls)) + (values #f #f)))) (define/private (tokenize-to-pos ls position) (when (and (not (lexer-state-up-to-date? ls)) From f0f7137803d1b5197ce434da4a45e53655c73c98 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 2 Feb 2011 19:00:27 -0700 Subject: [PATCH 02/29] fix `image-snip%' unmarshaling with filename Merge to 5.1 original commit: c2c6c79a15b12d2ca689a75ed519f1fb364e1fd8 --- collects/tests/gracket/wxme.rkt | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/collects/tests/gracket/wxme.rkt b/collects/tests/gracket/wxme.rkt index 4208af35..c436b39f 100644 --- a/collects/tests/gracket/wxme.rkt +++ b/collects/tests/gracket/wxme.rkt @@ -1347,4 +1347,23 @@ ;; ---------------------------------------- +(let () + (define (mk) (make-object image-snip% (collection-file-path "b-run.png" "icons") 'unknown #f #f)) + + (define is (mk)) + (define copy-is + (let () + (define sp (open-output-string)) + (define t (new text%)) + (send t insert (mk)) + (send t save-port sp) + (define t2 (new text%)) + (send t2 insert-port (open-input-string (get-output-string sp))) + (send t2 find-first-snip))) + + (expect (send (mk) get-filename) + (send copy-is get-filename))) + +;; ---------------------------------------- + (done) From 13a61d62d737d15ee1f832f0bc3c73adcd8b922b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 2 Feb 2011 20:10:44 -0600 Subject: [PATCH 03/29] adjust the wxme reader so that it now creates image-snip%s when it finds image-snips in file it used to create image% objects that were simple containers for the data in the file; the change _should_ be backwards compatibile; the only know incompatibility is that the get-filename method now returns a path instead of bytes (this is to match the image-snip% class) closes PR 1168 please merge to the 5.1 release branch original commit: 0fce29f552eeef416bfb66459123614518f02513 --- collects/scribblings/gui/wxme.scrbl | 20 +-- .../gracket/image-snip-unmarshalling.rkt | 142 ++++++++++++++++++ 2 files changed, 153 insertions(+), 9 deletions(-) create mode 100644 collects/tests/gracket/image-snip-unmarshalling.rkt diff --git a/collects/scribblings/gui/wxme.scrbl b/collects/scribblings/gui/wxme.scrbl index e4926095..875dd4bd 100644 --- a/collects/scribblings/gui/wxme.scrbl +++ b/collects/scribblings/gui/wxme.scrbl @@ -3,6 +3,7 @@ (for-label wxme wxme/editor wxme/image + racket/snip (except-in wxme/comment reader) (except-in wxme/xml reader) (except-in wxme/scheme reader) @@ -302,7 +303,7 @@ Several compatibility mappings are installed automatically for the @racketmodname[wxme] library. They correspond to popular graphical elements supported by various versions of DrRacket, including comment boxes, fractions, XML boxes, Racket boxes, text boxes, and images -generated by the ``world'' and ``image'' teachpacks (or, more +generated by the @racketmodname[htdp/image] teachpack (or, more generally, from @racketmodname[mrlib/cache-image-snip]), and test-case boxes. @@ -323,7 +324,8 @@ special-comment content is the readable instance. XML, Racket, and text boxes similarly produce instances of @racket[editor%] and @racket[readable<%>] that expand in the usual way; see @racketmodname[wxme/xml], @racketmodname[wxme/scheme], and -@racket[wxme/text]. Images from the ``world'' and ``image'' teachpacks +@racket[wxme/text]. Images from the +@racketmodname[htdp/image] teachpack are packaged as instances of @racket[cache-image%] from the @racketmodname[wxme/cache-image] library. Test-case boxes are packaged as instances of @racket[test-case%] from the @@ -353,14 +355,14 @@ editor's content.} @defmodule[wxme/image] -@defclass[image% object% ()]{ +@defclass[image% image-snip% ()]{ Instantiated for images in a @tech{WXME} stream in text mode. - -@defmethod[(get-filename) (or/c bytes? false/c)]{ - -Returns a filename as bytes, or @racket[#f] if data is available -instead.} +This class can just be treated like @racket[image-snip%] and should +behave just like it, except it has the methods below in addition +in case old code still needs them. In other words, the methods +below are provided for backwards compatibility with earlier +verisons of Racket. @defmethod[(get-data) (or/c bytes? false/c)]{ @@ -543,7 +545,7 @@ rational numbers.}] @defthing[reader (is-a?/c snip-reader<%>)]{ A text-mode reader for images in a WXME stream generated by the -``image'' and ``world'' teachpacks---or, more generally, by +@racketmodname[htdp/image] teachpack---or, more generally, by @racketmodname[mrlib/cache-image-snip].}] diff --git a/collects/tests/gracket/image-snip-unmarshalling.rkt b/collects/tests/gracket/image-snip-unmarshalling.rkt new file mode 100644 index 00000000..cb8a4937 --- /dev/null +++ b/collects/tests/gracket/image-snip-unmarshalling.rkt @@ -0,0 +1,142 @@ +#lang racket/gui +(require wxme + wxme/image) + +#| + +This file tests the wxme image-snip reader against the normal +image-snip reader (ie image-snip-class%'s read method) + +It creates a bunch of different image-snip% objects +(the try-perms and below functions) +and then feeds them thru both paths to get two new image snips +(in the beginning of test-wxme-image-snip-reader/proc) +and compares a bunch of properties of them +(the end of that function). + +|# + +(define-syntax (test-wxme-image-snip-reader stx) + (syntax-case stx () + [(_ is) + (with-syntax ([line (syntax-line stx)]) + #'(test-wxme-image-snip-reader/proc line is))])) + +(define tests 0) +(define (test-wxme-image-snip-reader/proc line is) + (set! tests (+ tests 1)) + (define t (new text%)) + (send t insert is) + (define sp (open-output-string)) + (void (send t save-port sp)) + (define wp (wxme-port->port (open-input-string (get-output-string sp)))) + (define wxme-is (read-char-or-special wp)) + + (define t2 (new text%)) + (send t2 insert-port (open-input-string (get-output-string sp))) + (define copy-is (send t2 find-first-snip)) + + (define (warn . args) + (fprintf (current-error-port) + (string-append (format "FAILED test-wxme-image-snip-reader.rkt line ~a: " line) + (apply format args)))) + + (define-syntax-rule (cmp mtd) (cmp/proc (λ (x) (send x mtd)) 'mtd)) + (define (cmp/proc call-mtd mtd) + (let ([is-ans (call-mtd is)] + [wxme-is-ans (call-mtd wxme-is)] + [copy-is-ans (call-mtd copy-is)]) + (unless (same? copy-is-ans wxme-is-ans) + (warn "~a returned different results; copy-is: ~s wxme-is: ~s\n" + mtd + copy-is-ans + wxme-is-ans)) + #; + (unless (same? is-ans copy-is-ans) + (warn "~a returned different results; is: ~s copy-is: ~s\n" + mtd + is-ans + copy-is-ans)))) + + (when (is-a? is image%) + (warn "the input image-snip% is an image%\n")) + + (unless (is-a? wxme-is image%) + (warn "new image snip is not an image%\n")) + + (cmp get-filename) + (cmp get-filetype) + (cmp get-bitmap) + (cmp get-bitmap-mask)) + +(define (same? x y) + (cond + [(and (is-a? x bitmap%) + (is-a? y bitmap%)) + (and (= (send x get-width) + (send y get-width)) + (= (send x get-height) + (send y get-height)) + (= (send x get-depth) + (send y get-depth)) + (check? (bitmap->bytes x #f) + (bitmap->bytes y #f) + 'bitmap/#f) + (check? (bitmap->bytes x #t) + (bitmap->bytes y #t) + 'bitmap/#t))] + [else (equal? x y)])) + + +(define (check? a b what) + (cond + [(equal? a b) #t] + [else + ;(fprintf (current-error-port) "checking ~s, doesn't match\n~s\nvs\n~s\n\n" what a b) + #f])) + +(define (bitmap->bytes bmp alpha?) + (define w (send bmp get-width)) + (define h (send bmp get-height)) + (define bytes (make-bytes (* 4 w h) 0)) + (send bmp get-argb-pixels 0 0 w h bytes alpha?) + bytes) + +(define (try-perms files kinds relative-path?s inline?s) + (for* ([file (in-list files)] + [kind (in-list kinds)] + [relative-path? (in-list relative-path?s)] + [inline? (in-list inline?s)]) + (test-wxme-image-snip-reader (make-object image-snip% file kind relative-path? inline?)))) + +(try-perms (list (collection-file-path "b-run.png" "icons")) + '(unknown unknown/mask unknown/alpha + png png/mask png/alpha) + '(#f) + '(#f #t)) + +(parameterize ([current-directory (collection-path "icons")]) + (try-perms (list "b-run.png") + '(unknown unknown/mask unknown/alpha + png png/mask png/alpha) + '(#f) + '(#f #t))) + +(define (draw-circle bm) + (define bdc (make-object bitmap-dc% bm)) + (send bdc set-smoothing 'smoothed) + (send bdc set-brush "red" 'solid) + (send bdc draw-ellipse 1 1 8 8) + (send bdc set-bitmap #f)) + +(let ([bm (make-bitmap 10 10 #f)]) + (draw-circle bm) + (test-wxme-image-snip-reader (make-object image-snip% bm)) + (test-wxme-image-snip-reader (make-object image-snip% bm #f)) + (test-wxme-image-snip-reader (make-object image-snip% bm bm))) + +(let ([bm (make-bitmap 10 10)]) + (draw-circle bm) + (test-wxme-image-snip-reader (make-object image-snip% bm))) + +(printf "ran ~a tests\n" tests) From 5007d739fc22fc6487bda790121c71429c7f5e36 Mon Sep 17 00:00:00 2001 From: David Van Horn Date: Wed, 2 Feb 2011 14:56:42 -0500 Subject: [PATCH 04/29] Fixed various spelling errors. original commit: c9519fd11300b07292df8619e86f48533eff6e4d --- collects/embedded-gui/doc.txt | 2 +- collects/embedded-gui/scribblings/embedded-gui.scrbl | 2 +- collects/framework/main.rkt | 2 +- collects/framework/private/scheme.rkt | 2 +- collects/mred/private/wx/cocoa/gauge.rkt | 2 +- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/win32/gl-context.rkt | 2 +- collects/mred/private/wxme/editor-snip.rkt | 2 +- collects/mred/private/wxme/mline.rkt | 2 +- collects/mrlib/image-core.rkt | 2 +- .../aligned-pasteboard/geometry-managed-pasteboard.rkt | 2 +- collects/mrlib/private/image-core-bitmap.rkt | 2 +- collects/scribblings/framework/canvas.scrbl | 2 +- collects/scribblings/framework/editor.scrbl | 2 +- collects/scribblings/framework/text.scrbl | 2 +- doc/release-notes/gracket/HISTORY.txt | 4 ++-- 16 files changed, 17 insertions(+), 17 deletions(-) diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt index f528ab78..09ff60af 100644 --- a/collects/embedded-gui/doc.txt +++ b/collects/embedded-gui/doc.txt @@ -257,7 +257,7 @@ alignment<%>. _stretchable-editor-snip-mixin_ gives an editor snip the _stretchable-snip<%>_ interface allowing it to be stretched -to fit it's alignment-parent<%>'s alloted width. Stretchable +to fit its alignment-parent<%>'s alloted width. Stretchable snips are useful as the snip of a snip-wrapper%. _stretchable-editor-snip%_ is (stretcable-editor-snip-mixin editor-snip%) diff --git a/collects/embedded-gui/scribblings/embedded-gui.scrbl b/collects/embedded-gui/scribblings/embedded-gui.scrbl index 2d5bd51a..e8c937fe 100644 --- a/collects/embedded-gui/scribblings/embedded-gui.scrbl +++ b/collects/embedded-gui/scribblings/embedded-gui.scrbl @@ -81,7 +81,7 @@ t hat are labeled from a particular set of strings.} Sets the tabbing order of @scheme[tabbable-text<%>]s by setting each text's @method[tabbable-text<%> set-ahead] and -@method[tabbable-text<%> set-back] thunks to point to it's neighbor in +@method[tabbable-text<%> set-back] thunks to point to its neighbor in the argument list.} diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 85c921a5..82b15b12 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -802,7 +802,7 @@ @scheme[filename]. @itemize[ @item{If a handler is found, it is applied to - @scheme[filename] and it's result is the final + @scheme[filename] and its result is the final result.} @item{If not, @scheme[make-default] is used.}]}]} @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] is diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index be69a203..6bf517c1 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -604,7 +604,7 @@ [(not contains) ;; Something went wrong matching. Should we get here? (do-indent 0)] - #; ;; disable this to accomodate PLAI programs; return to this when a #lang capability is set up. + #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. [(curley-brace-sexp?) ;; when we are directly inside an sexp that uses {}s, ;; we indent in a more C-like fashion (to help Scribble) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index 153b821b..caab7985 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -33,7 +33,7 @@ (super-new [parent parent] [cocoa (let ([cocoa (as-objc-allocation ;; Beware that a guage may be finally deallocated in - ;; a seperate OS-level thread + ;; a separate 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/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8c43cf8e..7db96daf 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -216,7 +216,7 @@ (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. + ;; grow if it doesn't have to grow to accommodate the menu bar. (send this resized)) (define saved-enforcements (vector 0 0 -1 -1)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt index 3da5c6e3..f7b8f0ce 100644 --- a/collects/mred/private/wx/win32/gl-context.rkt +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -137,7 +137,7 @@ PFD_SUPPORT_GDI) (bitwise-ior PFD_DRAW_TO_WINDOW))) PFD_TYPE_RGBA ; color type - (if offscreen? 32 24) ; prefered color depth + (if offscreen? 32 24) ; preferred color depth 0 0 0 0 0 0 ; color bits (ignored) 0 ; no alpha buffer 0 ; alpha bits (ignored) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 14f57369..0d715396 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -111,7 +111,7 @@ (when (and s-admin (has-flag? s-flags USES-BUFFER-PATH)) - ;; propogate a filename change: + ;; propagate a filename change: (if (and editor (no-permanent-filename? editor)) (let ([b (send s-admin get-editor)]) diff --git a/collects/mred/private/wxme/mline.rkt b/collects/mred/private/wxme/mline.rkt index 6d81eac8..0794bb89 100644 --- a/collects/mred/private/wxme/mline.rkt +++ b/collects/mred/private/wxme/mline.rkt @@ -1039,7 +1039,7 @@ Debugging tools: [next (mline-next mline)]) (when (or (not (eq? (mline-snip next) asnip)) (not (has-flag? (snip->flags (mline-last-snip next)) NEWLINE))) - ;; Effect can propogate to more lines, merging the + ;; Effect can propagate to more lines, merging the ;; next several. (Handle prefixing the remains of the source of ;; the extension to this line onto the next line. Implemented ;; as the next line eating the next->next line.) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 3cbd7890..8df14e75 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -255,7 +255,7 @@ has been moved out). (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 - [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. + [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accommodate that. (or ;(zero? w) ;(zero? h) (let ([bm1 (make-bitmap w h #t)] diff --git a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.rkt b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.rkt index 9d5e2abe..2773b2e7 100644 --- a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.rkt +++ b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.rkt @@ -50,7 +50,7 @@ (get-aligned-min-sizes type (find-first-snip))))) ;; set-algined-min-sizes (-> void?) - ;; set the aligned min width and height of the pasteboard based on it's children snips + ;; set the aligned min width and height of the pasteboard based on its children snips (inherit in-edit-sequence?) (define/public (aligned-min-sizes-invalid) ;; This in-edit-sequence? is not sound. It causes me to percollate invalidation diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 9b694af2..6a56a7f0 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -27,7 +27,7 @@ instead of this scaling code, we use the dc<%>'s scaling code. ; bmbytes: a bytes which represents an image -- -; it's size is a multiple of 4, and each +; its size is a multiple of 4, and each ; four consecutive bytes represent alpha,r,g,b. diff --git a/collects/scribblings/framework/canvas.scrbl b/collects/scribblings/framework/canvas.scrbl index ec1cc5c3..af73ef2b 100644 --- a/collects/scribblings/framework/canvas.scrbl +++ b/collects/scribblings/framework/canvas.scrbl @@ -53,7 +53,7 @@ Any @scheme[canvas%] that matches this interface will automatically - resize selected snips when it's size changes. Use + resize selected snips when its size changes. Use @method[canvas:wide-snip<%> add-tall-snip] and @method[canvas:wide-snip<%> add-wide-snip] diff --git a/collects/scribblings/framework/editor.scrbl b/collects/scribblings/framework/editor.scrbl index 64a353be..b683634f 100644 --- a/collects/scribblings/framework/editor.scrbl +++ b/collects/scribblings/framework/editor.scrbl @@ -346,7 +346,7 @@ the filesystem. The class that this mixin produces uses the same initialization - arguments as it's input. + arguments as its input. @defmethod*[#:mode override (((set-filename (name string) (temp? boolean |#f|)) void))]{ Updates the filename on each frame displaying this editor, for each diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 7aa92bce..09188b9b 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -156,7 +156,7 @@ objects in the framework. The class that this mixin produces uses the same initialization - arguments as it's input. + arguments as its input. @defmethod*[#:mode override (((on-paint (before? any/c) (dc (is-a?/c dc<%>)) (left real?) (top real?) (right real?) (bottom real?) (dx real?) (dy real?) (draw-caret (one-of/c (quote no-caret) (quote show-inactive-caret) (quote show-caret)))) void))]{ Draws the rectangles installed by diff --git a/doc/release-notes/gracket/HISTORY.txt b/doc/release-notes/gracket/HISTORY.txt index 75948fb3..8085ccf1 100644 --- a/doc/release-notes/gracket/HISTORY.txt +++ b/doc/release-notes/gracket/HISTORY.txt @@ -1285,7 +1285,7 @@ System: Changed force-redraw to ignore refresh requests when the redraw-requesting window is not shown. Redraw requests are now - propogated to the top-level frame or dialog via child-redraw-request. + propagated to the top-level frame or dialog via child-redraw-request. - if your application is unititized, then you need to change the startup procedure. See the application startup section in the toolbox manual. @@ -1655,7 +1655,7 @@ Bug fixes, especially Motif and memory bugs Rewrote editor line-maintenance Faster caret updating Upgraded garbage collector -File format changed to accomodate nested buffers with +File format changed to accommodate nested buffers with separate style lists Standard system standardized Code changes for compiling on MSWindows (almost works...) From e15a65221e81eb0094376cbd742704449591489e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 4 Feb 2011 04:30:12 -0500 Subject: [PATCH 05/29] Bump version numbers of mzscheme and mred. (These things should not be used anymore.) original commit: c4661de04926b08757efbd1d483fa6512f110f69 --- collects/mred/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/info.rkt b/collects/mred/info.rkt index 9b6cbaad..c522ee60 100644 --- a/collects/mred/info.rkt +++ b/collects/mred/info.rkt @@ -1,4 +1,4 @@ #lang setup/infotab -(define version '(400)) +(define version '(510)) (define post-install-collection "installer.rkt") From f04e67e91f7a0b0acfd6791e2fb9fd4d04d764ec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 07:25:02 -0700 Subject: [PATCH 06/29] cocoa: fix problems with `radio-box%' in no-selection mode Closes PR 11708 Merge to 5.1 original commit: 5d1b78384d390520edf970021bc0c144f78c259e --- collects/mred/private/wx/cocoa/radio-box.rkt | 21 ++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 237ec581..558418df 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -26,6 +26,9 @@ #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (clicked: [_id sender]) + ;; In case we were in 0-item mode, switch to Radio mode to + ;; ensure that only one button is selected: + (tellv self setMode: #:type _int NSRadioModeMatrix) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) (define-objc-class MyImageButtonCell NSButtonCell @@ -127,15 +130,21 @@ (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)))) + (begin + (tellv (get-cocoa) setMode: #:type _int NSRadioModeMatrix) + (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) - (tell #:type _NSInteger (get-cocoa) selectedRow))) + (let ([c (tell (get-cocoa) selectedCell)] + [pos (if horiz? + (tell #:type _NSInteger (get-cocoa) selectedColumn) + (tell #:type _NSInteger (get-cocoa) selectedRow))]) + (if (and c + (positive? (tell #:type _NSInteger c state))) + pos + -1))) (define/public (number) count) (define/override (maybe-register-as-child parent on?) From 8b7ca5060515aef2fa4fdf1d9122b65786799ae8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 08:49:22 -0700 Subject: [PATCH 07/29] cocoa: change `radio-box%' implementation of no selected buttons (not sure how I missed the `setAllowsEmptySelection' method before, but maybe there was some reason to avoid it that I've forgotten --- so *don't* merge to 5.1) original commit: e1303dc4006951d7c9e1ebee31d0f5a76ab3c40e --- collects/mred/private/wx/cocoa/radio-box.rkt | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 558418df..d52ef155 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -28,7 +28,7 @@ (-a _void (clicked: [_id sender]) ;; In case we were in 0-item mode, switch to Radio mode to ;; ensure that only one button is selected: - (tellv self setMode: #:type _int NSRadioModeMatrix) + (tellv self setAllowsEmptySelection: #:type _BOOL #f) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) (define-objc-class MyImageButtonCell NSButtonCell @@ -129,13 +129,12 @@ (define/public (set-selection i) (if (= i -1) (begin - ;; Need to change to NSListModeMatrix to disable all. - (tellv (get-cocoa) setMode: #:type _int NSListModeMatrix) + (tellv (get-cocoa) setAllowsEmptySelection: #:type _BOOL #t) (tellv (get-cocoa) deselectAllCells)) (begin - (tellv (get-cocoa) setMode: #:type _int NSRadioModeMatrix) (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) - column: #:type _NSInteger (if horiz? i 0))))) + column: #:type _NSInteger (if horiz? i 0)) + (tellv (get-cocoa) setAllowsEmptySelection: #:type _BOOL #f)))) (define/public (get-selection) (let ([c (tell (get-cocoa) selectedCell)] [pos (if horiz? From c16fdbac60aac6f6020337c29e3d27cba4cbb6ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 09:19:19 -0700 Subject: [PATCH 08/29] win32: fix horizontal `radio-box%' Merge to 5.1 original commit: 8f404a46187da3c21dcf52185d0912abdf3ba85f --- collects/mred/private/wx/win32/radio-box.rkt | 77 +++++++++++--------- 1 file changed, 41 insertions(+), 36 deletions(-) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index e395003a..329f5c86 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -49,42 +49,47 @@ (define label-bitmaps null) (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? (label . is-a? . bitmap%)] - [radio-hwnd - (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)) - (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP - (cast hbitmap _HBITMAP _LPARAM)))) - (ShowWindow radio-hwnd SW_SHOW) - (set-control-font font radio-hwnd) - (let-values ([(w1 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)))))))) + (let ([horiz? (memq 'horizontal style)]) + (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? (label . is-a? . bitmap%)] + [radio-hwnd + (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)) + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + (ShowWindow radio-hwnd SW_SHOW) + (set-control-font font radio-hwnd) + (let-values ([(w1 h) + (auto-size font label 0 0 20 4 + (lambda (w1 h1) + (if horiz? + (MoveWindow radio-hwnd (+ w SEP) 0 w1 h1 #t) + (MoveWindow radio-hwnd 0 (+ y SEP) w1 h1 #t)) + (values w1 h1)))]) + (cons radio-hwnd + (loop (if horiz? (max y h) (+ y SEP h)) + (if horiz? (+ w SEP w1) (max w1 w)) + (cdr labels))))))))) (unless (= val -1) (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) From 08dccaa1c445e7170d89bc8a1ca58efdd9c5e788 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 19:17:11 -0700 Subject: [PATCH 09/29] cocoa: yet another hack around weird cocoa behavior Closes PR 11712 Merge to 5.1 original commit: 845ca2d58668c40c2ce2ab314867974877b2da93 --- collects/mred/private/wx/cocoa/slider.rkt | 7 +++++++ collects/mred/private/wx/cocoa/window.rkt | 7 ++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index c0e820e3..e735287d 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -8,6 +8,7 @@ "const.rkt" "utils.rkt" "window.rkt" + "queue.rkt" "../common/event.rkt" "../common/queue.rkt" "../common/freeze.rkt" @@ -158,6 +159,12 @@ (define/public (update-message [val (get-value)]) (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))) + (inherit get-cocoa-window) + (define/override (post-mouse-down) + ;; For some reason, dragging a slider disabled mouse-moved + ;; events for the window, so turn them back on: + (tellv (get-cocoa-window) setAcceptsMouseMovedEvents: #:type _BOOL #t)) + (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 409b6ef5..906c0349 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -98,7 +98,10 @@ [wxb] [-a _void (mouseDown: [_id event]) (unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down) - (super-tell #:type _void mouseDown: event))] + (super-tell #:type _void mouseDown: event) + (let ([wx (->wx wxb)]) + (when wx + (send wx post-mouse-down))))] [-a _void (mouseUp: [_id event]) (unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up) (super-tell #:type _void mouseUp: event))] @@ -727,6 +730,8 @@ [caps-down #f]) #f)) + (define/public (post-mouse-down) (void)) + (define/public (on-char s) (void)) (define/public (on-event m) (void)) (define/public (queue-on-size) (void)) From 15c7ab6e1f846a59b677149b96906ecb50d6d382 Mon Sep 17 00:00:00 2001 From: David Van Horn Date: Fri, 4 Feb 2011 16:46:32 -0500 Subject: [PATCH 10/29] Fixes more spelling errors. original commit: 760a58b65df2b91010d2bcc2739ddab2a4489729 --- collects/embedded-gui/doc.txt | 2 +- collects/embedded-gui/private/alignment.rkt | 14 +++++++------- collects/framework/private/group.rkt | 2 +- collects/framework/private/handler.rkt | 2 +- collects/framework/private/text.rkt | 4 ++-- collects/mred/private/misc.rkt | 2 +- collects/mred/private/seqcontract.rkt | 6 +++--- collects/mred/private/wx/cocoa/gauge.rkt | 2 +- collects/mred/private/wxme/pasteboard.rkt | 4 ++-- collects/mred/private/wxme/text.rkt | 4 ++-- collects/mrlib/cache-image-snip.rkt | 2 +- collects/mrlib/name-message.rkt | 2 +- .../mrlib/private/aligned-pasteboard/alignment.rkt | 14 +++++++------- .../private/aligned-pasteboard/pasteboard-lib.rkt | 2 +- collects/mrlib/scribblings/tex-table.scrbl | 2 +- collects/scribblings/framework/editor.scrbl | 4 ++-- collects/scribblings/framework/text.scrbl | 2 +- collects/tests/framework/README | 4 ++-- doc/release-notes/gracket/HISTORY.txt | 2 +- doc/release-notes/gracket/MrEd_100_Framework.txt | 4 ++-- 20 files changed, 40 insertions(+), 40 deletions(-) diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt index 09ff60af..2f0affea 100644 --- a/collects/embedded-gui/doc.txt +++ b/collects/embedded-gui/doc.txt @@ -292,7 +292,7 @@ interface and gives it key bindings to tab ahead and back. The _set-tabbing_ function sets the tabbing order of tabbable-text<%>s by setting each text's set-ahead and -set-back thunks to point to it's neighbor in the argument +set-back thunks to point to its neighbor in the argument list. > (set-tabbing a-text ...) diff --git a/collects/embedded-gui/private/alignment.rkt b/collects/embedded-gui/private/alignment.rkt index 593b1fc6..3a89451e 100644 --- a/collects/embedded-gui/private/alignment.rkt +++ b/collects/embedded-gui/private/alignment.rkt @@ -1,19 +1,19 @@ #| -This code computes the sizes for the rectangles in the space using the on dimention -off dimention method of referencing sizes. This means for example instead of saying -width we say off dimention for vertical alignment. Inorder to consume and return +This code computes the sizes for the rectangles in the space using the on dimension +off dimension method of referencing sizes. This means for example instead of saying +width we say off dimension for vertical alignment. Inorder to consume and return the values in terms of width and height manipulation had to be done. I chose to create a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect stucts on to them. This code is a bit long but more readable than the other two options I came up with. 1) define all functions to be letrec bound functions inside align. align then take - accessors for the rect struct. The caller of align swaps the order of ondimention - and off dimention accessors for vertical or horizontal code. This method does not + accessors for the rect struct. The caller of align swaps the order of ondimension + and off dimension accessors for vertical or horizontal code. This method does not allow the use of the readable, short, consis pattern matching code. As some of the matching code is easily removed this may be a good option but a large letrec is harder to write tests for. 2) define a pattern matcher syntax that will match the struct rect but swap the fields - based on wich on is the on or off dimention. This would have been shorter but much + based on which on is the on or off dimension. This would have been shorter but much more confusing. The current implementation requires align to map over the rects and allocate new stucts for each one on both passing into and returning from stretch-to-fit; This is not a bottle @@ -138,7 +138,7 @@ neck and it is the most readable solution. (loop rest-rects (+ onpos onsize))))])))) #;(natural-number? . -> . (-> (union 1 0))) - ;; makes a thunk that returns 1 for it's first n applications, zero otherwise + ;; makes a thunk that returns 1 for its first n applications, zero otherwise (define (waner n) (lambda () (if (zero? n) diff --git a/collects/framework/private/group.rkt b/collects/framework/private/group.rkt index 81811652..97bb3057 100644 --- a/collects/framework/private/group.rkt +++ b/collects/framework/private/group.rkt @@ -256,7 +256,7 @@ (define/public (locate-file name) (let* ([normalized - ;; allow for the possiblity of filenames that are urls + ;; allow for the possibility of filenames that are urls (with-handlers ([(λ (x) #t) (λ (x) name)]) (normal-case-path diff --git a/collects/framework/private/handler.rkt b/collects/framework/private/handler.rkt index 3890f7eb..74aeb94d 100644 --- a/collects/framework/private/handler.rkt +++ b/collects/framework/private/handler.rkt @@ -209,7 +209,7 @@ (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 + ;; the new-items variable should 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]) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index bb9e6c94..db9e3001 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -2160,7 +2160,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; - ;; output port syncronization code + ;; output port synchronization code ;; ;; flush-chan : (channel (evt void)) @@ -3121,7 +3121,7 @@ designates the character that triggers autocompletion (show-options word start-pos end-pos completion-cursor))))) ;; Number -> String - ;; The word that ends at the current positon of the editor + ;; The word that ends at the current position of the editor (define/public (get-word-at current-pos) (let ([start-pos (box current-pos)]) (find-wordbreak start-pos #f 'caret) diff --git a/collects/mred/private/misc.rkt b/collects/mred/private/misc.rkt index 0df20606..c66afbf0 100644 --- a/collects/mred/private/misc.rkt +++ b/collects/mred/private/misc.rkt @@ -48,7 +48,7 @@ ;; the alarm is immediately ready. This makes `sleep/yield' ;; more like `sleep': (wx:yield) - ;; Now, realy sleep: + ;; Now, really sleep: (wx:yield evt)) (void)) diff --git a/collects/mred/private/seqcontract.rkt b/collects/mred/private/seqcontract.rkt index 34fad331..0d22e5d5 100644 --- a/collects/mred/private/seqcontract.rkt +++ b/collects/mred/private/seqcontract.rkt @@ -410,13 +410,13 @@ Matthew set-before ;SetBefore set-after ;SetAfter ;ReallyCanEdit -- only when op != wxEDIT_COPY - ;Refresh has wierd code checking writeLocked -- what does < 0 mean? + ;Refresh has weird code checking writeLocked -- what does < 0 mean? do-paste ; DoPaste paste ; Paste insert-port ; InsertPort insert-file ; InsertFile read-from-file ; ReadFromFile - ; BeginEditSequence ;; -- wierd flag check - ; EndEditSequence ;; -- wierd flag check, like BeginEditSequence + ; BeginEditSequence ;; -- weird flag check + ; EndEditSequence ;; -- weird flag check, like BeginEditSequence |# diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index caab7985..4d349cc2 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -32,7 +32,7 @@ (super-new [parent parent] [cocoa (let ([cocoa (as-objc-allocation - ;; Beware that a guage may be finally deallocated in + ;; Beware that a gauge may be finally deallocated in ;; a separate OS-level thread (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index f52f7c02..31e5de61 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -1729,10 +1729,10 @@ (set-box! h total-height)) (send s-admin get-view x y w h #t)) (let ([w (if (w . > . 1000.0) - 500.0 ; don't belive it + 500.0 ; don't believe it w)] [h (if (h . > . 1000.0) - 500.0 ; don't belive it + 500.0 ; don't believe it h)]) (values (/ w 2) (/ h 2))))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index d29faf08..6a75b34e 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -2849,7 +2849,7 @@ (set! write-locked? #t) (set! flow-locked? #t) - ;; linear seach for snip + ;; linear search for snip (let ([topy (mline-get-location line)]) (let loop ([snip (mline-snip line)] [X X] @@ -3159,7 +3159,7 @@ (values (mline-last-snip line) (+ horiz (- (mline-w line) (mline-last-w line))) start #f)] [else - ;; linear seach for snip + ;; linear search for snip (let loop ([snip (mline-snip line)] [start start] [horiz horiz] diff --git a/collects/mrlib/cache-image-snip.rkt b/collects/mrlib/cache-image-snip.rkt index 1f26d096..88f4b2ce 100644 --- a/collects/mrlib/cache-image-snip.rkt +++ b/collects/mrlib/cache-image-snip.rkt @@ -21,7 +21,7 @@ The true meaning of an image is a vector of rationals, between 0 & 255, representing color and alpha channel - information. The vector's contents are analagous to + information. The vector's contents are analogous to the last argument to the get-argb-pixels method. That is, there are (* 4 w h) entries in the vector for an image of width w and height h, and the entries represent the diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index bbb0d956..38d94f0b 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -255,7 +255,7 @@ (+ border-inset circle-spacer button-label-inset - (if (eq? (system-type) 'windows) 1 0) ;; becuase "(define ...)" has the wrong size under windows + (if (eq? (system-type) 'windows) 1 0) ;; because "(define ...)" has the wrong size under windows (max 0 (inexact->exact (ceiling tw))) button-label-inset triangle-width diff --git a/collects/mrlib/private/aligned-pasteboard/alignment.rkt b/collects/mrlib/private/aligned-pasteboard/alignment.rkt index 2741e527..3aa0f44b 100644 --- a/collects/mrlib/private/aligned-pasteboard/alignment.rkt +++ b/collects/mrlib/private/aligned-pasteboard/alignment.rkt @@ -1,19 +1,19 @@ #| -This code computes the sizees for the rectangles in the space using the on dimention -off dimention method of referencing sizes. This means for example instead of saying -width we say off dimention for vertical alignment. Inorder to consume and return +This code computes the sizees for the rectangles in the space using the on dimension +off dimension method of referencing sizes. This means for example instead of saying +width we say off dimension for vertical alignment. Inorder to consume and return the values in terms of width and height manipulation had to be done. I chose to create a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect stucts on to them. This code is a bit long but more readable than the other two options I came up with. 1) define all functions to be letrec bound functions inside align. align then take - accessors for the rect struct. The caller of align swaps the order of ondimention - and off dimention accessors for vertical or horizontal code. This method does not + accessors for the rect struct. The caller of align swaps the order of ondimension + and off dimension accessors for vertical or horizontal code. This method does not allow the use of the readable, short, consis pattern matching code. As some of the matching code is easily removed this may be a good option but a large letrec is harder to write tests for. 2) define a pattern matcher syntax that will match the struct rect but swap the fields - based on wich on is the on or off dimention. This would have been shorter but much + based on wich on is the on or off dimension. This would have been shorter but much more confusing. The current implementation requires align to map over the rects and allocate new stucts for each one on both passing into and returning from stretch-to-fit; This is not a bottle @@ -141,7 +141,7 @@ neck and it is the most readable solution. (loop rest-rects (+ onpos onsize))))])))) ;; waner (natural-number? . -> . (-> (union 1 0))) - ;; makes a thunk that returns 1 for it's first n applications, zero otherwise + ;; makes a thunk that returns 1 for its first n applications, zero otherwise (define (waner n) (lambda () (if (zero? n) diff --git a/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.rkt b/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.rkt index 50d1ddfc..9d6a0042 100644 --- a/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.rkt +++ b/collects/mrlib/private/aligned-pasteboard/pasteboard-lib.rkt @@ -27,7 +27,7 @@ [else pasteboard]))) ;; gets the canvas or snip that the pasteboard is displayed in - ;; status: what if there is more than one canvas? should this be allowed? probablly not. + ;; status: what if there is more than one canvas? should this be allowed? probably not. (define (pasteboard-parent pasteboard) (let ([admin (send pasteboard get-admin)]) (cond diff --git a/collects/mrlib/scribblings/tex-table.scrbl b/collects/mrlib/scribblings/tex-table.scrbl index 88a5614d..477fc9f6 100644 --- a/collects/mrlib/scribblings/tex-table.scrbl +++ b/collects/mrlib/scribblings/tex-table.scrbl @@ -14,7 +14,7 @@ (= (string-length x) 1)))))]{ - This is an assocation list mapping the shortcut strings that + This is an association list mapping the shortcut strings that DrRacket uses with its @tt{control-\} (or @tt{command-\}) strings to their corresponding unicode characters. For example, it contains this mapping: diff --git a/collects/scribblings/framework/editor.scrbl b/collects/scribblings/framework/editor.scrbl index b683634f..2de107b3 100644 --- a/collects/scribblings/framework/editor.scrbl +++ b/collects/scribblings/framework/editor.scrbl @@ -379,7 +379,7 @@ @definterface[editor:backup-autosave<%> (editor:basic<%>)]{ Classes matching this interface support backup files and autosaving. @defmethod*[(((backup?) boolean?))]{ - Indicates weather this + Indicates whether this @scheme[editor<%>] should be backed up. @@ -392,7 +392,7 @@ } @defmethod*[(((autosave?) boolean?))]{ - Indicates weather this + Indicates whether this @scheme[editor<%>] should be autosaved. diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 09188b9b..5f11748b 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -135,7 +135,7 @@ } @defmethod[(get-edition-number) exact-nonnegative-integer?]{ - Returns a number that increments everytime something in + Returns a number that increments every time something in the editor changes. The number is updated in @xmethod[text% after-insert] and diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 81ad4ef7..a9dae2dd 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -1,7 +1,7 @@ (#| Framework Test Suite Overview -Each test will rely on the sucessfully completion of all of the ones +Each test will rely on the successfully completion of all of the ones before it. In addition, all test suites rely on the sucessful completion of the engine test suites and the mzscheme test suites. @@ -29,7 +29,7 @@ signal failures when there aren't any. - load: |# load.rkt #| | This tests that the advertised ways of loading the framework at - | it's components all work. + | its components all work. - exit: |# exit.rkt #| diff --git a/doc/release-notes/gracket/HISTORY.txt b/doc/release-notes/gracket/HISTORY.txt index 8085ccf1..2bffa405 100644 --- a/doc/release-notes/gracket/HISTORY.txt +++ b/doc/release-notes/gracket/HISTORY.txt @@ -373,7 +373,7 @@ Version 206p1, February 2004 Fixed printing scale for Windows NT/2000/XP -Version 206, Janurary 2004 +Version 206, January 2004 Drawing: Changed get-argb-pixels and set-argb-pixels to row-major order: diff --git a/doc/release-notes/gracket/MrEd_100_Framework.txt b/doc/release-notes/gracket/MrEd_100_Framework.txt index 2c062d7c..e3d26796 100644 --- a/doc/release-notes/gracket/MrEd_100_Framework.txt +++ b/doc/release-notes/gracket/MrEd_100_Framework.txt @@ -115,7 +115,7 @@ The moved functions and classes are: mred:graph-pasteboard% mred:node-snip% -The remaining existant classes: +The remaining existent classes: frame:empty% = (frame:make-empty% frame%) frame:standard-menus% = (frame:make-standard-menus% frame:empty%) @@ -294,4 +294,4 @@ NOTE: some used but non-existant interfaces from mred engine: snip:make-basic-style% : snip<%> -> snip<%> - scheme:make-text% : text:basic<%> -> scheme:text<%> \ No newline at end of file + scheme:make-text% : text:basic<%> -> scheme:text<%> From 35e0433bcc1e55d1a8c7d447a22bdb9aa8630374 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 13:33:37 -0700 Subject: [PATCH 11/29] adjust `racket/gui/base' to re-export `file/resource' Merge to 5.1 along with b4ce4bb, 3375005, 18eb7c8, 3c4807f original commit: 5eeec97878e2491688514f03fe3898f6ea4dd933 --- collects/mred/mred-sig.rkt | 2 ++ collects/mred/private/mred.rkt | 4 +++- collects/scribblings/gui/gui.scrbl | 3 ++- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 15 ++++++++++++--- 4 files changed, 19 insertions(+), 5 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index fc8dec47..ffee1409 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -91,6 +91,7 @@ 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 @@ -210,4 +211,5 @@ window<%> write-editor-global-footer write-editor-global-header write-editor-version +write-resource yield diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 72594f60..889008b6 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -5,6 +5,7 @@ make-base-empty-namespace) scheme/class racket/draw racket/snip + file/resource mzlib/etc (prefix wx: "kernel.ss") (prefix wx: "wxme/editor.ss") @@ -169,7 +170,8 @@ [else #f]))) (provide (all-from racket/draw) - (all-from racket/snip)) + (all-from racket/snip) + (all-from file/resource)) (provide button% canvas% diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 4321754b..177cb159 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -10,7 +10,8 @@ @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, in addition -to the bindings of @racketmodname[racket/draw].} +to the bindings of @racketmodname[racket/draw] and +@racketmodname[file/resource].} @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_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index d44cc4d9..fec9eab2 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -156,12 +156,21 @@ jump-defeating `dynamic-wind' that formerly guarded callbacks has been removed. +Registry Functions +----------------- + +The `get-resource' and `write-resource' functions have moved to a +`file/resource' library that is re-exported by `racket/gui/base'. +These function now work only for reading and writing the Windows +registry; they report failure for other platforms and modes. + + 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 `send-event' function has 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 From 2a7f32d7f8bfbbac5a0d4fd2b7a309f2ce70d9b2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Feb 2011 14:11:30 -0700 Subject: [PATCH 12/29] minor correction to release notes Merge to 5.1 original commit: ead1c366d19eefb7b2489a062e18e8c410242ef0 --- 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 fec9eab2..63c19627 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -162,7 +162,7 @@ Registry Functions The `get-resource' and `write-resource' functions have moved to a `file/resource' library that is re-exported by `racket/gui/base'. These function now work only for reading and writing the Windows -registry; they report failure for other platforms and modes. +registry or ".ini" files; they report failure for other platforms. Removed Functions From 5d29afbabb9e19618fa4683678717c3189d12958 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Feb 2011 16:48:04 -0700 Subject: [PATCH 13/29] document limitations of `on-subwindow-event' and `on-subwindow-char' Merge to 5.1 original commit: e2a0fd02ef89da7d8efbfe26739ca82d8a42c7ad --- collects/scribblings/gui/window-intf.scrbl | 18 +++++++++++++++--- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 5 +++++ 2 files changed, 20 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/gui/window-intf.scrbl b/collects/scribblings/gui/window-intf.scrbl index 3c3645b8..17318469 100644 --- a/collects/scribblings/gui/window-intf.scrbl +++ b/collects/scribblings/gui/window-intf.scrbl @@ -374,6 +374,14 @@ Called when this window or a child window receives a keyboard event. @method[window<%> on-subwindow-char] method returns @scheme[#f], the event is passed on to the receiver's normal key-handling mechanism. +The @scheme[event] argument is the event that was generated for the + @scheme[receiver] window. + +The atomicity limitation @method[window<%> on-subwindow-event] applies + to @method[window<%> on-subwindow-char] as well. That is, an insufficiently cooperative + @method[window<%> on-subwindow-char] method can effectively disable + a control's handling of key events, even when it returns @racket[#f] + BEWARE: The default @xmethod[frame% on-subwindow-char] and @xmethod[dialog% on-subwindow-char] methods consume certain keyboard events (e.g., arrow keys, Enter) used @@ -382,9 +390,6 @@ BEWARE: The default reach the ``receiver'' child unless the default frame or dialog method is overridden. -The @scheme[event] argument is the event that was generated for the - @scheme[receiver] window. - } @methimpl{ @@ -409,6 +414,13 @@ Called when this window or a child window receives a mouse event. The @scheme[event] argument is the event that was generated for the @scheme[receiver] window. +If the @method[window<%> on-subwindow-event] method chain does not complete + atomically (i.e., without requiring other threads to run) or does not complete + fast enough, then the corresponding event may not be delivered to a target + control, such as a button. In other words, an insufficiently cooperative + @method[window<%> on-subwindow-event] method can effectively disable a + control's handling of mouse events, even when it returns @racket[#f]. + } @methimpl{ 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 63c19627..128f037b 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -155,6 +155,11 @@ callbacks or outside of an even callback. The continuation barrier and jump-defeating `dynamic-wind' that formerly guarded callbacks has been removed. +The `on-subwindow-char' and `on-subwindow-event' methods for controls +are somewhat more restructed in the actions they can take without +disabling the control's handling of key and mouse events. See the +documentation for more information. + Registry Functions ----------------- From cc016fe9fc694c291a2f256aa20c1628022db8ca Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 30 Jan 2011 08:57:38 -0600 Subject: [PATCH 14/29] started to fix the colorer problems (now that I undestand how!) plus some extra checking in the colorer original commit: 49c3011f49caae37a496a25d482e5b8855def3ee --- collects/framework/private/color.rkt | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 365c48f0..1ade5b4e 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -297,6 +297,14 @@ added get-regions (get-token in in-start-pos in-lexer-mode) (enable-suspend #t)))]) (unless (eq? 'eof type) + (unless (exact-nonnegative-integer? new-token-start) + (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) + (unless (exact-nonnegative-integer? new-token-end) + (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) + (unless (exact-nonnegative-integer? backup-delta) + (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) + (unless (0 . < . (- new-token-end new-token-start)) + (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) (enable-suspend #f) #; (printf "~a at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) (+ in-start-pos (sub1 new-token-end))) From 923787b89c279dfea6a1a63a4e7a0a4d6ad18666 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 8 Feb 2011 13:00:58 -0700 Subject: [PATCH 15/29] add mixin for splitting panels original commit: 878787e6f32357d432f094b083205054e04363bb --- collects/framework/private/panel.rkt | 112 +++++++++++++++++++++++++++ collects/framework/private/sig.rkt | 5 +- 2 files changed, 116 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index 86d56509..1099a2cc 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -505,3 +505,115 @@ (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) +(define splitter<%> (interface () split-horizontal split-vertical collapse)) +;; we need a private interface so we can use `generic' because `generic' +;; doesn't work on mixins +(define splitter-private<%> (interface () self-vertical? self-horizontal?)) + +(define splitter-mixin + (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) + (super-new) + (inherit get-children add-child + delete-child + change-children + begin-container-sequence + end-container-sequence) + + (field [horizontal-panel% horizontal-dragable%] + [vertical-panel% vertical-dragable%]) + + (define/public (self-vertical?) + (send this get-vertical?)) + + (define/public (self-horizontal?) + (not (send this get-vertical?))) + + ;; insert an item into a list after some element + (define/private (insert-after list before item) + (let loop ([so-far '()] + [list list]) + (cond + [(null? list) (reverse so-far)] + [(eq? (car list) before) (loop (cons item (cons before so-far)) + (cdr list))] + [else (loop (cons (car list) so-far) (cdr list))]))) + + ;; replace an element with a list of stuff + (define/private (replace list at stuff) + (let loop ([so-far '()] + [list list]) + (cond + [(null? list) (reverse so-far)] + [(eq? (car list) at) (append (reverse so-far) stuff (cdr list))] + [else (loop (cons (car list) so-far) (cdr list))]))) + + (define/public (collapse canvas) + (begin-container-sequence) + (for ([child (get-children)]) + (cond + [(eq? child canvas) + (when (> (length (get-children)) 1) + (change-children + (lambda (old-children) + (remq canvas old-children))))] + [(is-a? child splitter<%>) + (send child collapse canvas)])) + (change-children + (lambda (old-children) + (for/list ([child old-children]) + (if (and (is-a? child splitter<%>) + (= (length (send child get-children)) 1)) + (let () + (define single (car (send child get-children))) + (send single reparent this) + single) + child)))) + (end-container-sequence)) + + ;; split a canvas by creating a new editor and either + ;; 1) adding it to the canvas if the canvas is already using the same + ;; orientation as the split that is about to occur + ;; 2) create a new panel with the orientation of the split about to + ;; occur and add a new editor + ;; + ;; in both cases the new editor is returned + (define/private (do-split canvas maker orientation? orientation% split) + (define new-canvas #f) + (for ([child (get-children)]) + (cond + [(eq? child canvas) + (begin-container-sequence) + (change-children + (lambda (old-children) + (if (send-generic this orientation?) + (let ([new (maker this)]) + (set! new-canvas new) + (insert-after old-children child new)) + (let () + (define container (new (splitter-mixin orientation%) + [parent this])) + (send canvas reparent container) + (define created (maker container)) + (set! new-canvas created) + ;; this throws out the old child but we should probably + ;; try to keep it + (replace old-children child (list container)))))) + (end-container-sequence)] + + [(is-a? child splitter<%>) + (let ([something (send-generic child split canvas maker)]) + (when something + (set! new-canvas something)))])) + new-canvas) + + ;; canvas (widget -> editor) -> editor + (define/public (split-horizontal canvas maker) + (do-split canvas maker (generic splitter-private<%> self-horizontal?) + horizontal-panel% (generic splitter<%> split-horizontal))) + + ;; canvas (widget -> editor) -> editor + (define/public (split-vertical canvas maker) + (do-split canvas maker (generic splitter-private<%> self-vertical?) + vertical-panel% (generic splitter<%> split-vertical))) + + )) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index d37a6dd0..5d342e98 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -57,7 +57,10 @@ horizontal-dragable<%> horizontal-dragable-mixin - horizontal-dragable%)) + horizontal-dragable% + + splitter<%> + splitter-mixin)) (define-signature panel^ extends panel-class^ (dragable-container-size dragable-place-children)) From dc520a9a4774954df1cd41eb5402327682c50f33 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 8 Feb 2011 14:46:02 -0700 Subject: [PATCH 16/29] add documentation for the splitter mixin original commit: 7f3f861899403f3a271b35c473878a35ed472e41 --- collects/framework/private/panel.rkt | 6 +++- collects/scribblings/framework/panel.scrbl | 34 ++++++++++++++++++++++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index 1099a2cc..364414c8 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -529,6 +529,7 @@ (not (send this get-vertical?))) ;; insert an item into a list after some element + ;; FIXME: this is probably a library function somewhere (define/private (insert-after list before item) (let loop ([so-far '()] [list list]) @@ -539,6 +540,7 @@ [else (loop (cons (car list) so-far) (cdr list))]))) ;; replace an element with a list of stuff + ;; FIXME: this is probably a library function somewhere (define/private (replace list at stuff) (let loop ([so-far '()] [list list]) @@ -547,6 +549,8 @@ [(eq? (car list) at) (append (reverse so-far) stuff (cdr list))] [else (loop (cons (car list) so-far) (cdr list))]))) + ;; remove a canvas and merge split panels if necessary + ;; TODO: restore percentages (define/public (collapse canvas) (begin-container-sequence) (for ([child (get-children)]) @@ -571,7 +575,7 @@ (end-container-sequence)) ;; split a canvas by creating a new editor and either - ;; 1) adding it to the canvas if the canvas is already using the same + ;; 1) adding it to the panel if the panel is already using the same ;; orientation as the split that is about to occur ;; 2) create a new panel with the orientation of the split about to ;; occur and add a new editor diff --git a/collects/scribblings/framework/panel.scrbl b/collects/scribblings/framework/panel.scrbl index e3cd08d5..20c362e6 100644 --- a/collects/scribblings/framework/panel.scrbl +++ b/collects/scribblings/framework/panel.scrbl @@ -174,4 +174,38 @@ @defclass[panel:vertical-dragable% (panel:vertical-dragable-mixin (panel:dragable-mixin vertical-panel%)) ()]{} @defclass[panel:horizontal-dragable% (panel:horizontal-dragable-mixin (panel:dragable-mixin horizontal-panel%)) ()]{} +@definterface[panel:splitter<%> ()]{ + A panel that implements @scheme[panel:splitter<%>]. Children can be split + horizonally or vertically. +} + +@defmixin[panel:splitter-mixin (area-container<%> panel:dragable<%>) (splitter<%>)]{ + This mixin allows panels to split their children either horizontally or + vertically. Children that are split can be further split independant of any + other splitting. + + @defmethod[(split-vertical (canvas (instance-of (is-a?/c canvas<%>))) + (maker (-> (instance-of (is-a?/c splitter<%>)) + (instance-of (is-a?/c canvas<%>))))) + (instance-of (is-a?/c canvas<%>))]{ + Splits the @scheme[canvas] vertically by creating a new instance using + @scheme[maker]. This splitter object is passed as the argument to + @scheme[maker] and should be used as the @scheme[parent] field of the newly + created canvas. + } + + @defmethod[(split-horizontal (canvas (instance-of (is-a?/c canvas<%>))) + (maker (-> (instance-of (is-a?/c splitter<%>)) + (instance-of (is-a?/c canvas<%>))))) + (instance-of (is-a?/c canvas<%>))]{ + Similar to @scheme[split-vertical] but splits horizontally. + } + + @defmethod[(collapse (canvas (instance-of (is-a?/c canvas<%>)))) void]{ + Removes the given @scheme[canvas] from the splitter hierarchy and collapses + any split panes as necessary. + } + +} + @(include-previously-extracted "main-extracts.ss" #rx"^panel:") From 13af6a6145b6b3ba2b3c3394ae198b75cc22c236 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 07:41:19 -0700 Subject: [PATCH 17/29] gtk: fix X selection for older Gtk versions Merge to 5.1 original commit: f21f0bdba2af7282b747e858d81379135a5189a9 --- 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 22264bdf..c049a012 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -25,7 +25,6 @@ (define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkDisplay _pointer) -(define _GtkSelectionData (_cpointer 'GtkSelectionData)) ;; Recent versions of Gtk provide function calls to ;; access data, but use structure when the functions are @@ -38,6 +37,7 @@ [length _int] [display _GtkDisplay])) +(define _GtkSelectionData _GtkSelectionDataT-pointer) (define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom)) From ebaef0c71b0837e939186204d1bade6d26062101 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 09:01:22 -0700 Subject: [PATCH 18/29] fix `set-icon' in frame% to make mask argument optional Merge to 5.1 original commit: f4a881f0e37f291c604ae40ab52d2e36ca411609 --- collects/mred/private/wx/cocoa/frame.rkt | 2 +- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/win32/frame.rkt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index c70d89d2..c6d31f78 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -549,7 +549,7 @@ (define/public (on-activate on?) (void)) - (define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME + (define/public (set-icon bm1 [bm2 #f] [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/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 7db96daf..aa334ace 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -334,7 +334,7 @@ (define big-icon #f) (define small-icon #f) - (define/public (set-icon bm mask [mode 'both]) + (define/public (set-icon bm [mask #f] [mode 'both]) (let ([bm (if mask (let* ([nbm (make-object bitmap% (send bm get-width) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 712f5ffd..8a32696d 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -527,7 +527,7 @@ (define small-hicon #f) (define big-hicon #f) - (define/public (set-icon bm mask [mode 'both]) + (define/public (set-icon bm [mask #f] [mode 'both]) (let* ([bg-hbitmap (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] [dc (make-object bitmap-dc% bm)]) From f5eb37ea09ba3789d9fe1cec50918e3eaf813bcc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 12:23:14 -0700 Subject: [PATCH 19/29] win32: fix parent HWND of canvas% Merge to 5.1 original commit: 6b1112a9adad14b4bb4fd49431697a493b781622 --- collects/mred/private/wx/win32/canvas.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 0c5ddba9..a6723720 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -116,7 +116,7 @@ (if hscroll? WS_HSCROLL 0) (if vscroll? WS_VSCROLL 0)) 0 0 w h - (or panel-hwnd (send parent get-hwnd)) + (or panel-hwnd (send parent get-client-hwnd)) #f hInstance #f)) From 3ec8eca0f9b215faa550d9a6a34274da15ee7603 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 12:42:36 -0700 Subject: [PATCH 20/29] fix s:home keybinding Merge to 5.1 original commit: 33db7b1229e4be54c3ef0cf06eef86761c70a623 --- collects/framework/private/keymap.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index ab94d1bd..54fca114 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -1127,7 +1127,7 @@ (add "make-read-only" make-read-only) (add "beginning-of-line" beginning-of-line) - (add "selec-to-beginning-of-line" select-to-beginning-of-line) + (add "select-to-beginning-of-line" select-to-beginning-of-line) ; Map keys to functions From c830b5a1bcde45353a3c5e585fe60fc4c3df2c89 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 Feb 2011 17:28:01 -0600 Subject: [PATCH 21/29] changed the module lexer's strategy to be able to handle the part of the buffer before the #lang line properly closes PR 11381 original commit: d659d2f0afe8b0d8711f58d7b6761ed9dcd48e62 --- collects/framework/private/color.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 1ade5b4e..4120e3aa 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -320,7 +320,7 @@ added get-regions (sp (+ in-start-pos (sub1 new-token-start))) (ep (+ in-start-pos (sub1 new-token-end)))) (λ () - (change-style color sp ep #f))) + (change-style color sp ep #f))) colors))) ;; Using the non-spec version takes 3 times as long as the spec ;; version. In other words, the new greatly outweighs the tree From 3848e3da6c912db6d0a1e7b8d13d4d94db786e70 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 9 Feb 2011 12:07:46 -0700 Subject: [PATCH 22/29] use the standard editor style to get the right colors in the line numbers mixin. closes pr11655 original commit: 5bb72d5b0e01d022ce49ad360bc1333029c0ea56 --- collects/framework/private/text.rkt | 31 ++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index db9e3001..9ea667bf 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3720,7 +3720,7 @@ designates the character that triggers autocompletion ;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin - (mixin ((class->interface text%)) (line-numbers<%>) + (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) (inherit get-visible-line-range get-visible-position-range last-line @@ -3732,7 +3732,7 @@ designates the character that triggers autocompletion set-padding get-padding) - (init-field [line-numbers-color "black"]) + (init-field [line-numbers-color #f]) (init-field [show-line-numbers? #t]) ;; whether the numbers are aligned on the left or right ;; only two values should be 'left or 'right @@ -3774,9 +3774,12 @@ designates the character that triggers autocompletion (define style-change-notify (lambda (style) (unless style (setup-padding)))) - (define/private (get-style-font) - (let* ([style-list (send this get-style-list)] - [std (or (send style-list find-named-style "Standard") + (define/private (get-style) + (let* ([style-list (editor:get-standard-style-list)] + [std (or (send style-list + find-named-style + (editor:get-default-color-style-name)) + (send style-list find-named-style "Standard") (send style-list basic-style))]) ;; If the style changes, we should re-check the width of ;; drawn line numbers: @@ -3785,8 +3788,13 @@ designates the character that triggers autocompletion (send style-list notify-on-change style-change-notify) ;; Avoid registering multiple notifications: (set! notify-registered-in-list style-list)) - ;; Extract the font from the style: - (send std get-font))) + std)) + + (define/private (get-style-foreground) + (send (get-style) get-foreground)) + + (define/private (get-style-font) + (send (get-style) get-font)) (define-struct saved-dc-state (pen font foreground-color)) (define/private (save-dc-state dc) @@ -3799,11 +3807,16 @@ designates the character that triggers autocompletion (send dc set-font (saved-dc-state-font dc-state)) (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) + (define/private (get-foreground) + (if line-numbers-color + (make-object color% line-numbers-color) + (get-style-foreground))) + ;; set the dc stuff to values we want (define/private (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))) + (send dc set-text-foreground (get-foreground))) (define/private (lighter-color color) (define (integer number) @@ -3914,7 +3927,7 @@ designates the character that triggers autocompletion (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))) + (send dc set-text-foreground (get-foreground))) (draw-text view final-x final-y))) (set! last-paragraph (line-paragraph line)))) From 96a9bcd3630ded5f9de48428c72d5d29e0e436cf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 14:21:33 -0700 Subject: [PATCH 23/29] fix typos Merge to 5.1 original commit: 379feaeac2ebd07b17ebc6f54d04c084171410e9 --- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) 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 128f037b..75d625c2 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -17,7 +17,7 @@ API: Racket. The GRacket executable still offers some additional GUI-specific - functiontality however. Most notably, GRacket is a GUI application + functionality 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 @@ -91,8 +91,8 @@ 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. +backward-compatible. Methods like `get-translation', +`set-translation', `scale', etc. help hide the redundancy. PostScript, PDF, and SVG Drawing Contexts @@ -150,13 +150,13 @@ into the control. Event callbacks are delimited by a continuation prompt using the default continuation prompt tag. As a result, continuations can be -usufully captured during one event callback and applied during other +usefully captured during one event callback and applied during other callbacks or outside of an even callback. The continuation barrier and jump-defeating `dynamic-wind' that formerly guarded callbacks has been removed. The `on-subwindow-char' and `on-subwindow-event' methods for controls -are somewhat more restructed in the actions they can take without +are somewhat more restricted in the actions they can take without disabling the control's handling of key and mouse events. See the documentation for more information. From 966927e141e44df79593e59291bee9326bf08d45 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 1 Feb 2011 22:21:23 -0600 Subject: [PATCH 24/29] at attempt to use the dc's scale and rotation to instead of doing the rotation in racket original commit: 7eefe74e93e6ceda0c1baa370f4dc89e68863e70 --- collects/mrlib/image-core.rkt | 47 +++++++++++++++++++++++++++-------- 1 file changed, 37 insertions(+), 10 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 8df14e75..4064efc1 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -863,16 +863,43 @@ has been moved out). (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 set-smoothing 'smoothed) - (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)))] + [(flip? np-atomic-shape) + (cond + [#t ; (flip-flipped? 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)) + (- dy (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (get-rendered-mask np-atomic-shape)))] + + [else + ;; this only works when the scale is 1 and there is no flipping + (define bitmap (flip-shape np-atomic-shape)) + (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap))) + (define θ (degrees->radians (ibitmap-angle bitmap))) + (define w (send orig-bitmap-obj get-width)) + (define h (send orig-bitmap-obj get-height)) + (define c2 + (* (- (make-rectangular dx dy) + (* (make-polar 1 (- θ)) + (make-rectangular (/ w 2) (/ h 2)))) + (make-polar 1 θ))) + + (define orig-rotation (send dc get-rotation)) + (send dc set-rotation θ) + (send dc draw-bitmap + orig-bitmap-obj + (real-part c2) + (imag-part c2) + 'solid + (send the-color-database find-color "black") + orig-mask-obj) + (send dc set-rotation orig-rotation)])] [(text? np-atomic-shape) (let ([θ (degrees->radians (text-angle np-atomic-shape))] [font (send dc get-font)]) From 2f49294a6fc0777d252cc2f4895360bcd88f68a9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 12:00:57 -0600 Subject: [PATCH 25/29] Revert "at attempt to use the dc's scale and rotation to instead of doing the rotation in racket" This reverts commit 7eefe74e93e6ceda0c1baa370f4dc89e68863e70. original commit: 5e70dc863e7d965241a8d456e99d500d9f389fcc --- collects/mrlib/image-core.rkt | 47 ++++++++--------------------------- 1 file changed, 10 insertions(+), 37 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 4064efc1..8df14e75 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -863,43 +863,16 @@ has been moved out). (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) - (cond - [#t ; (flip-flipped? 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)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] - - [else - ;; this only works when the scale is 1 and there is no flipping - (define bitmap (flip-shape np-atomic-shape)) - (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap))) - (define θ (degrees->radians (ibitmap-angle bitmap))) - (define w (send orig-bitmap-obj get-width)) - (define h (send orig-bitmap-obj get-height)) - (define c2 - (* (- (make-rectangular dx dy) - (* (make-polar 1 (- θ)) - (make-rectangular (/ w 2) (/ h 2)))) - (make-polar 1 θ))) - - (define orig-rotation (send dc get-rotation)) - (send dc set-rotation θ) - (send dc draw-bitmap - orig-bitmap-obj - (real-part c2) - (imag-part c2) - 'solid - (send the-color-database find-color "black") - orig-mask-obj) - (send dc set-rotation orig-rotation)])] + [(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)) + (- 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)]) From e49a922ccef229a4dc08c801726f343044aeffec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Feb 2011 05:48:06 -0700 Subject: [PATCH 26/29] cocoa: FFI type corrections original commit: aea79be7a4b6baf6add8281866773cd6d452dfb7 --- collects/mred/private/wx/cocoa/queue.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 0480478f..f74b25be 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -49,7 +49,7 @@ (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) [] - [-a _int (applicationShouldTerminate: [_id app]) + [-a _NSUInteger (applicationShouldTerminate: [_id app]) (queue-quit-event) 0] [-a _BOOL (openPreferences: [_id app]) @@ -120,7 +120,7 @@ (import-class NSEvent) (define wake-evt (tell NSEvent - otherEventWithType: #:type _int NSApplicationDefined + otherEventWithType: #:type _NSUInteger NSApplicationDefined location: #:type _NSPoint (make-NSPoint 0.0 0.0) modifierFlags: #:type _NSUInteger 0 timestamp: #:type _double 0.0 From a67b2a6cb0c64f1bee8825b37b1b12c7947cc8e6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 Feb 2011 08:08:17 -0600 Subject: [PATCH 27/29] adjusted printfs to make them a little narrower original commit: d5c753be88dfc223647315f9e7df7bf72b837cb1 --- collects/tests/framework/main.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/tests/framework/main.rkt b/collects/tests/framework/main.rkt index e4d3caec..ca6a207d 100644 --- a/collects/tests/framework/main.rkt +++ b/collects/tests/framework/main.rkt @@ -58,12 +58,12 @@ `("Names of the tests; defaults to all non-interactive tests")) (when (file-exists? preferences-file) - (debug-printf admin " saving preferences file ~s\n" preferences-file) - (debug-printf admin " to ~s\n" old-preferences-file) + (debug-printf admin " saving prefs file ~a\n" preferences-file) + (debug-printf admin " to ~a\n" old-preferences-file) (if (file-exists? old-preferences-file) - (debug-printf admin " backup preferences file exists, using that one\n") + (debug-printf admin " backup prefs file exists, using that one\n") (begin (copy-file preferences-file old-preferences-file) - (debug-printf admin " saved preferences file\n")))) + (debug-printf admin " saved prefs file\n")))) (define jumped-out-tests '()) @@ -96,12 +96,12 @@ (debug-printf schedule "ran ~a test~a\n" number-of-tests (if (= 1 number-of-tests) "" "s")) (when (file-exists? old-preferences-file) - (debug-printf admin " restoring preferences file ~s\n" old-preferences-file) - (debug-printf admin " to ~s\n" preferences-file) + (debug-printf admin " restoring prefs file ~a\n" old-preferences-file) + (debug-printf admin " to ~a\n" preferences-file) (delete-file preferences-file) (copy-file old-preferences-file preferences-file) (delete-file old-preferences-file) - (debug-printf admin " restored preferences file\n")) + (debug-printf admin " restored prefs file\n")) (shutdown-listener) From 4c89ce420d073a140ed39482602c4121782745c1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 Feb 2011 08:59:36 -0600 Subject: [PATCH 28/29] adjust the framework test suite so that queue-sexp-to-mred catches and propogates exceptions original commit: 62c961410cb8b865f3ae0feda125b3fbc75d48d2 --- collects/tests/framework/test-suite-utils.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/tests/framework/test-suite-utils.rkt b/collects/tests/framework/test-suite-utils.rkt index dd5ec200..3802d829 100644 --- a/collects/tests/framework/test-suite-utils.rkt +++ b/collects/tests/framework/test-suite-utils.rkt @@ -144,8 +144,11 @@ (send-sexp-to-mred `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene [c (make-channel)]) - (queue-callback (lambda () (channel-put c (thunk)))) - (channel-get c))))) + (queue-callback (lambda () (channel-put c (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) (list 'normal (thunk)))))) + (let ([res (channel-get c)]) + (if (eq? (list-ref res 0) 'normal) + (list-ref res 1) + (raise (list-ref res 1)))))))) (define re:tcp-read-error (regexp "tcp-read:")) (define re:tcp-write-error (regexp "tcp-write:")) From 4c0a52964db3532b45a3d5b839abc788cc550422 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 Feb 2011 09:00:22 -0600 Subject: [PATCH 29/29] lift the restriction that the text:ports mixin cannot do io from the eventspace handler thread and add a test suite for text:ports original commit: 8e94ce49e417ca57547702e5b40b201e27edb5bb --- collects/framework/private/text.rkt | 65 +++++++--- collects/scribblings/framework/text.scrbl | 7 +- collects/tests/framework/text.rkt | 142 ++++++++++++++++++++++ 3 files changed, 196 insertions(+), 18 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9ea667bf..47aa6f52 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -1825,6 +1825,9 @@ (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define msec-timeout 500) + +;; this value (4096) is also mentioned in the test suite (collects/tests/framework/test.rkt) +;; so if you change it, be sure to change things over there too (define output-buffer-full 4096) (define-local-member-name @@ -1873,6 +1876,17 @@ (send value-sd set-delta-foreground (make-object color% 0 0 175)) (create-style-name value-style-name value-sd))) +;; data : any +;; to-insert-chan : (or/c #f channel) +;; if to-insert-chan is a channel, this means +;; the eventspace handler thread is the one that +;; is initiating the communication, so instead of +;; queueing a callback to do the update of the editor, +;; just send the work back directly and it will be done +;; syncronously there. If it is #f, then we queue a callback +;; to do the work +(define-struct data/chan (data to-insert-chan)) + (define ports-mixin (mixin (wide-snip<%>) (ports<%>) (inherit begin-edit-sequence @@ -2241,7 +2255,7 @@ (after-io-insertion)))) (define/public (after-io-insertion) (void)) - + (define output-buffer-thread (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")]) (thread @@ -2257,13 +2271,16 @@ (alarm-evt (+ last-flush msec-timeout)) (λ (_) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) + ;; we always queue the work here since the always event means no one waits for the callback (queue-insertion viable-bytes always-evt) (loop remaining-queue (current-inexact-milliseconds)))))) (handle-evt flush-chan - (λ (return-evt) + (λ (return-evt/to-insert-chan) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) - (queue-insertion viable-bytes return-evt) + (if (channel? return-evt/to-insert-chan) + (channel-put return-evt/to-insert-chan viable-bytes) + (queue-insertion viable-bytes return-evt/to-insert-chan)) (loop remaining-queue (current-inexact-milliseconds))))) (handle-evt clear-output-chan @@ -2271,16 +2288,22 @@ (loop (empty-queue) (current-inexact-milliseconds)))) (handle-evt write-chan - (λ (pr) + (λ (pr-pr) + (define return-chan (car pr-pr)) + (define pr (cdr pr-pr)) (let ([new-text-to-insert (enqueue pr text-to-insert)]) (cond [((queue-size text-to-insert) . < . output-buffer-full) + (when return-chan + (channel-put return-chan '())) (loop new-text-to-insert last-flush)] [else (let ([chan (make-channel)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter new-text-to-insert)]) - (queue-insertion viable-bytes (channel-put-evt chan (void))) + (if return-chan + (channel-put return-chan viable-bytes) + (queue-insertion viable-bytes (channel-put-evt chan (void)))) (channel-get chan) (loop remaining-queue (current-inexact-milliseconds))))])))))))))) @@ -2300,16 +2323,23 @@ (λ (to-write start end block/buffer? enable-breaks?) (cond [(= start end) (flush-proc)] - [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'write-bytes-proc "cannot write to port on eventspace main thread")] [else - (channel-put write-chan (cons (subbytes to-write start end) style))]) + (define pair (cons (subbytes to-write start end) style)) + (cond + [(eq? (current-thread) (eventspace-handler-thread eventspace)) + (define return-channel (make-channel)) + (thread (λ () (channel-put write-chan (cons return-channel pair)))) + (do-insertion (channel-get return-channel) #f)] + [else + (channel-put write-chan (cons #f pair))])]) (- end start))) (define (flush-proc) (cond [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'flush-proc "cannot flush port on eventspace main thread")] + (define to-insert-channel (make-channel)) + (thread (λ () (channel-put flush-chan to-insert-channel))) + (do-insertion (channel-get to-insert-channel) #f)] [else (sync (nack-guard-evt @@ -2327,17 +2357,18 @@ (define (make-write-special-proc style) (λ (special can-buffer? enable-breaks?) + (define str/snp (cond + [(string? special) special] + [(is-a? special snip%) special] + [else (format "~s" special)])) + (define to-send (cons str/snp style)) (cond [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'write-bytes-proc "cannot write to port on eventspace main thread")] + (define return-chan (make-channel)) + (thread (λ () (channel-put write-chan (cons return-chan to-send)))) + (do-insertion (channel-get return-chan) #f)] [else - (let ([str/snp (cond - [(string? special) special] - [(is-a? special snip%) special] - [else (format "~s" special)])]) - (channel-put - write-chan - (cons str/snp style)))]) + (channel-put write-chan (cons #f to-send))]) #t)) (let* ([add-standard diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 5f11748b..4c59ee40 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -818,7 +818,7 @@ } @definterface[text:ports<%> ()]{ Classes implementing this interface (via the associated - mixin) support input and output ports that read from the + mixin) support input and output ports that read from and to the editor. There are two input ports: the normal input port just reads @@ -826,6 +826,11 @@ inserts an editor snip into this text and uses input typed into the box as input into the port. + There are three output ports, designed to match stdout, stderr, + and a special port for printing values. The only difference + between them is the output is rendered in different colors + when it comes in via the different ports. + They create three threads to mediate access to the input and output ports (one for each input port and one for all of the output ports). diff --git a/collects/tests/framework/text.rkt b/collects/tests/framework/text.rkt index 25dbaa5e..b3ae4463 100644 --- a/collects/tests/framework/text.rkt +++ b/collects/tests/framework/text.rkt @@ -196,3 +196,145 @@ (send dc clear) (send t print-to-dc dc 1) 'no-error)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; text:ports +;; + +;; there is an internal buffer of this size, so writes that are larger and smaller are interesting +(define buffer-size 4096) + +(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))] + [non-ascii-str "λαβ一二三四五"]) + + (define (do/separate-thread str mtd) + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t ,mtd)] + [exn #f]) + (yield + (thread + (λ () + (with-handlers ((exn:fail? (λ (x) (set! exn x)))) + (display ,str op) + (flush-output op))))) + (when exn (raise exn)) + (send t get-text 0 (send t last-position))))) + + (test + 'text:ports%.1 + (λ (x) (equal? x "abc")) + (λ () (do/separate-thread "abc" 'get-out-port))) + + (test + 'text:ports%.2 + (λ (x) (equal? x big-str)) + (λ () (do/separate-thread big-str 'get-out-port))) + + (test + 'text:ports%.3 + (λ (x) (equal? x non-ascii-str)) + (λ () (do/separate-thread non-ascii-str 'get-out-port))) + + (test + 'text:ports%.4 + (λ (x) (equal? x "abc")) + (λ () (do/separate-thread "abc" 'get-err-port))) + + (test + 'text:ports%.5 + (λ (x) (equal? x big-str)) + (λ () (do/separate-thread big-str 'get-err-port))) + + (test + 'text:ports%.6 + (λ (x) (equal? x non-ascii-str)) + (λ () (do/separate-thread non-ascii-str 'get-err-port))) + + + (test + 'text:ports%.7 + (λ (x) (equal? x "abc")) + (λ () (do/separate-thread "abc" 'get-value-port))) + + (test + 'text:ports%.8 + (λ (x) (equal? x big-str)) + (λ () (do/separate-thread big-str 'get-value-port))) + + (test + 'text:ports%.9 + (λ (x) (equal? x non-ascii-str)) + (λ () (do/separate-thread non-ascii-str 'get-value-port))) + + ;; display the big string, one char at a time + (test + 'text:ports%.10 + (λ (x) (equal? x big-str)) + (λ () + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t get-out-port)] + [big-str ,big-str] + [exn #f]) + (yield + (thread + (λ () + (with-handlers ((exn:fail? (λ (x) (set! exn x)))) + (let loop ([i 0]) + (when (< i (string-length big-str)) + (display (string-ref big-str i) op) + (loop (+ i 1)))) + (flush-output op))))) + (when exn (raise exn)) + (send t get-text 0 (send t last-position)))))) + + ;; the next tests test the interaction when the current + ;; thread is the same as the handler thread of the eventspace + ;; where the text was created + + (test + 'text:ports%.thd1 + (λ (x) (equal? x "abc")) + (λ () + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t get-out-port)] + [exn #f]) + (display "abc" op) + (flush-output op) + (send t get-text 0 (send t last-position)))))) + + (test + 'text:ports%.thd2 + (λ (x) (equal? x big-str)) + (λ () + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t get-out-port)]) + (display ,big-str op) + (flush-output op) + (send t get-text 0 (send t last-position)))))) + + (test + 'text:ports%.thd3 + (λ (x) (equal? x non-ascii-str)) + (λ () + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t get-out-port)]) + (display ,non-ascii-str op) + (flush-output op) + (send t get-text 0 (send t last-position)))))) + + (test + 'text:ports%.thd4 + (λ (x) (equal? x non-ascii-str)) + (λ () + (queue-sexp-to-mred + `(let* ([t (new (text:ports-mixin text:wide-snip%))] + [op (send t get-out-port)]) + (display ,non-ascii-str op) + (flush-output op) + (send t get-text 0 (send t last-position)))))))