diff --git a/collects/framework/gui-utils.rkt b/collects/framework/gui-utils.rkt index 7c89d95c..6faa0923 100644 --- a/collects/framework/gui-utils.rkt +++ b/collects/framework/gui-utils.rkt @@ -111,36 +111,36 @@ (define (cancel-on-right?) (system-position-ok-before-cancel?)) -(define ok/cancel-buttons - (lambda (parent - confirm-callback - cancel-callback - [confirm-str (string-constant ok)] - [cancel-str (string-constant cancel)]) - (let ([confirm (λ () - (instantiate button% () - (parent parent) - (callback confirm-callback) - (label confirm-str) - (style '(border))))] - [cancel (λ () - (instantiate button% () - (parent parent) - (callback cancel-callback) - (label cancel-str)))]) - (let-values ([(b1 b2) - (cond - [(cancel-on-right?) - (values (confirm) (cancel))] - [else - (values (cancel) (confirm))])]) - (let ([w (max (send b1 get-width) - (send b2 get-width))]) - (send b1 min-width w) - (send b2 min-width w) - (if (cancel-on-right?) - (values b1 b2) - (values b2 b1))))))) +(define (ok/cancel-buttons parent + confirm-callback + cancel-callback + [confirm-str (string-constant ok)] + [cancel-str (string-constant cancel)] + #:confirm-style [confirm-style '(border)]) + (let ([confirm (λ () + (instantiate button% () + (parent parent) + (callback confirm-callback) + (label confirm-str) + (style confirm-style)))] + [cancel (λ () + (instantiate button% () + (parent parent) + (callback cancel-callback) + (label cancel-str)))]) + (let-values ([(b1 b2) + (cond + [(cancel-on-right?) + (values (confirm) (cancel))] + [else + (values (cancel) (confirm))])]) + (let ([w (max (send b1 get-width) + (send b2 get-width))]) + (send b1 min-width w) + (send b2 min-width w) + (if (cancel-on-right?) + (values b1 b2) + (values b2 b1)))))) (define clickback-delta (make-object style-delta% 'change-underline #t)) @@ -346,24 +346,30 @@ ((is-a?/c button%) (is-a?/c event%) . -> . any) ((is-a?/c button%) (is-a?/c event%) . -> . any)) (string? - string?) + string? + #:confirm-style (listof symbol?)) (values (is-a?/c button%) (is-a?/c button%))) ((parent confirm-callback cancel-callback) ((confirm-label (string-constant ok)) - (cancel-label (string-constant cancel)))) + (cancel-label (string-constant cancel)) + (confirm-style '(border)))) @{Adds an Ok and a cancel button to a panel, changing the order to suit the platform. Under Mac OS X and unix, the confirmation action is on the right (or bottom) and under Windows, the canceling action is on the right (or bottom). - The confirmation action button has the @scheme['(border)] style. The buttons are also sized to be the same width. The first result is be the OK button and the second is the cancel button. + By default, the confirmation action button has the @scheme['(border)] style, + meaning that hitting return in the dialog will trigger the confirmation action. + The @racket[confirm-style] argument can override this behavior, tho. + See @racket[button%] for the precise list of allowed styles. + See also @scheme[gui-utils:cancel-on-right?].}) (proc-doc/names diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 3c9e5ed1..6a8a7a37 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -4,20 +4,19 @@ namespace-anchor->empty-namespace make-base-empty-namespace) scheme/class - racket/draw + racket/draw racket/snip mzlib/etc (prefix wx: "private/kernel.ss") (prefix wx: "private/wxme/style.ss") (prefix wx: "private/wxme/editor.ss") (prefix wx: "private/wxme/text.ss") (prefix wx: "private/wxme/pasteboard.ss") - (prefix wx: "private/wxme/snip.ss") (prefix wx: "private/wxme/keymap.ss") (prefix wx: "private/wxme/editor-admin.ss") + (prefix wx: "private/wxme/editor-data.ss") (prefix wx: "private/wxme/editor-snip.ss") (prefix wx: "private/wxme/stream.ss") (prefix wx: "private/wxme/wordbreak.ss") - (prefix wx: "private/wxme/snip-admin.ss") "private/wxtop.ss" "private/app.ss" "private/misc.ss" @@ -68,7 +67,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (make-eventspace) - (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)] + (parameterize ([the-snip-class-list (make-the-snip-class-list)] [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)]) (wx:make-eventspace))) @@ -120,8 +119,6 @@ get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list - get-the-snip-class-list - image-snip% is-busy? is-color-display? key-event% @@ -142,19 +139,13 @@ read-editor-global-header read-editor-version scroll-event% - snip% - snip-admin% - snip-class% - snip-class-list<%> special-control-key special-option-key map-command-as-meta-key label->plain-label - string-snip% style<%> style-delta% style-list% - tab-snip% write-editor-global-footer write-editor-global-header write-editor-version @@ -183,7 +174,8 @@ [else ".gracketrc"]))] [else #f]))) - (provide (all-from racket/draw)) + (provide (all-from racket/draw) + (all-from racket/snip)) (provide button% canvas% @@ -274,7 +266,6 @@ view-control-font menu-control-font timer% - readable-snip<%> open-input-text-editor open-input-graphical-file open-output-text-editor diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 3749c5b5..017fef68 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -3,67 +3,18 @@ racket/port syntax/moddep (prefix-in wx: "kernel.ss") - (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: racket/snip) (prefix-in wx: "wxme/cycle.ss") "check.ss" "editor.ss") - (provide readable-snip<%> - open-input-text-editor + (provide open-input-text-editor open-input-graphical-file text-editor-load-handler open-output-text-editor ) - ;; snip-class% and editor-data-class% loaders - - (define (ok-string-element? m) - (and (string? m) - (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m) - (not (string=? m "..")) - (not (string=? m ".")))) - - (define (ok-lib-path? m) - (and (pair? m) - (eq? 'lib (car m)) - (pair? (cdr m)) - (list? m) - (andmap ok-string-element? (cdr m)))) - - (let ([load-one - (lambda (str id %) - (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)]) - (and (regexp-match #rx"^[(].*[)]$" str) - (let* ([p (open-input-string str)] - [m (read p)]) - (and (eof-object? (read p)) - m))))]) - (if (or (ok-lib-path? m) - (and (list? m) - (= (length m) 2) - (ok-lib-path? (car m)) - (ok-lib-path? (cadr m)))) - (let ([m (if (ok-lib-path? m) - m - (car m))]) - (let ([result (dynamic-require m id)]) - (if (is-a? result %) - result - (error 'load-class "not a ~a% instance" id)))) - #f)))]) - ;; install the getters: - (wx:set-get-snip-class! - (lambda (name) - (load-one name 'snip-class wx:snip-class%))) - (wx:set-get-editor-data-class! - (lambda (name) - (load-one name 'editor-data-class wx:editor-data-class%)))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define readable-snip<%> - (interface () - read-special)) - (define empty-string (make-bytes 0)) ;; open-input-text-editor : (instanceof text%) num num -> input-port @@ -188,7 +139,7 @@ (next-snip empty-string) (lambda (file line col ppos) (if (is-a? the-snip wx:snip%) - (if (is-a? the-snip readable-snip<%>) + (if (is-a? the-snip wx:readable-snip<%>) (send the-snip read-special file line col ppos) (send the-snip copy)) the-snip)))] @@ -212,7 +163,7 @@ v))) close)]) (when lock-while-reading? - (send text begin-edit-sequencce) + (send text begin-edit-sequence) (send text lock #t)) (if (is-a? snip wx:string-snip%) ;; Special handling for initial snip string in diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7e3d0cdb..4da18982 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -245,7 +245,8 @@ client-to-screen is-auto-scroll? get-virtual-width get-virtual-height reset-auto-scroll - refresh-for-autoscroll) + refresh-for-autoscroll + flush) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) @@ -360,7 +361,7 @@ (tellv content-cocoa setDelegate: content-cocoa) (install-control-font content-cocoa #f)) - (define dc (make-object dc% this)) + (define dc (make-object dc% this (memq 'transparent canvas-style))) (send dc start-backing-retained) @@ -382,6 +383,7 @@ (define/override (get-client-size xb yb) (super get-client-size xb yb) (when is-combo? + (set-box! xb (max 0 (- (unbox xb) 22))) (set-box! yb (max 0 (- (unbox yb) 5))))) (define/override (maybe-register-as-child parent on?) @@ -396,15 +398,16 @@ (define/override (show on?) ;; FIXME: what if we're in the middle of an on-paint? - (super show on?) - (fix-dc)) + (super show on?)) (define/override (hide-children) (super hide-children) + (fix-dc #f) (suspend-all-reg-blits)) (define/override (show-children) (super show-children) + (fix-dc) (resume-all-reg-blits)) (define/override (fixup-locations-children) @@ -627,6 +630,13 @@ (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) #t) (define/public (on-combo-select i) (void)) + (define/public (popup-combo) + ;; Pending refresh events intefere with combo popups + ;; for some reason, so flush them: + (yield-refresh) + (flush) + ;; Beware that the `popUp:' method is undocumented: + (tellv (tell content-cocoa cell) popUp: #f)) (define clear-bg? (and (not (memq 'transparent canvas-style)) (not (memq 'no-autoclear canvas-style)))) @@ -718,7 +728,7 @@ (let ([xb (box 0)] [yb (box 0)]) (get-client-size xb yb) - ((send e get-x) . > . (- (unbox xb) 22)))) + ((send e get-x) . > . (unbox xb)))) (define/public (on-popup) (void)) @@ -764,12 +774,10 @@ (void)) (define/public (get-backing-size xb yb) - (get-client-size xb yb) - (when is-combo? - (set-box! xb (- (unbox xb) 22)))) + (get-client-size xb yb)) (define/override (get-cursor-width-delta) - (if is-combo? 22 0)) + 0) (define/public (is-flipped?) (tell #:type _BOOL (get-cocoa-content) isFlipped)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b739fa88..0b821447 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -23,11 +23,12 @@ (define dc% (class backing-dc% - (init [(cnvs canvas)]) + (init [(cnvs canvas)] + transparent?) (define canvas cnvs) (inherit end-delay) - (super-new) + (super-new [transparent? transparent?]) (define gl #f) (define/override (get-gl-context) @@ -89,13 +90,6 @@ (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))] [cr (cairo_create surface)]) (cairo_surface_destroy surface) - (let ([s (cairo_get_source cr)]) - (cairo_pattern_reference s) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 (unbox w) (unbox h)) - (cairo_fill cr) - (cairo_set_source cr s) - (cairo_pattern_destroy s)) + (backing-draw-bm bm cr (unbox w) (unbox h)) (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index d8f0bdc0..eb3b7ace 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -16,20 +16,14 @@ ;; ---------------------------------------- -(import-class NSTextField NSImageView NSWorkspace) +(import-class NSTextField NSImageView NSWorkspace NSRunningApplication) (define _OSType _uint32) (define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id)) (define (get-app-icon) - (tell (tell NSWorkspace sharedWorkspace) - iconForFile: - (tell (tell (tell NSWorkspace sharedWorkspace) - activeApplication) - objectForKey: - #:type _NSString - "NSApplicationPath"))) + (tell (tell NSRunningApplication currentApplication) icon)) (define (make-icon label) (let ([icon diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index f6c9b3b5..d095a881 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -4,11 +4,14 @@ racket/draw/private/bitmap-dc racket/draw/private/bitmap racket/draw/private/local + racket/draw/private/record-dc + racket/draw/unsafe/cairo "../../lock.rkt" "queue.rkt") (provide (protect-out backing-dc% + backing-draw-bm ;; scoped method names: get-backing-size @@ -35,13 +38,19 @@ end-delay) (define backing-dc% - (class (dc-mixin bitmap-dc-backend%) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init transparent?) + (inherit internal-get-bitmap internal-set-bitmap - reset-cr) + reset-cr + set-recording-limit + get-recorded-command) (super-new) + (set-recording-limit (if transparent? 1024 -1)) + (define/override (ok?) #t) ;; Override this method to get the right size @@ -67,7 +76,8 @@ [(not retained-cr) #f] [(positive? retained-counter) (unless nada? - (proc (internal-get-bitmap))) + (proc (or (get-recorded-command) + (internal-get-bitmap)))) #t] [else (reset-backing-retained proc) @@ -155,3 +165,43 @@ (define (release-backing-bitmap bm) (send bm release-bitmap-storage)) + +(define cairo-dc + (make-object (dc-mixin + (class default-dc-backend% + (inherit reset-cr) + + (define cr #f) + (define w 0) + (define h 0) + + (super-new) + + (define/public (set-cr new-cr new-w new-h) + (set! cr new-cr) + (set! w new-w) + (set! h new-h) + (when cr + (reset-cr cr))) + + (define/override (get-cr) cr) + + (define/override (reset-clip cr) + (super reset-clip cr) + (cairo_rectangle cr 0 0 w h) + (cairo_clip cr)))))) + +(define (backing-draw-bm bm cr w h) + (if (procedure? bm) + (begin + (send cairo-dc set-cr cr w h) + (bm cairo-dc) + (send cairo-dc set-cr #f 0 0)) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)))) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 07c4364f..9cf8abd7 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -143,7 +143,8 @@ (let ([pq paint-queued]) (when pq (set-box! pq #f))) (set! paint-queued #f) - (when (or (not b) (is-shown-to-root?)) + (cond + [(or (not b) (is-shown-to-root?)) (let ([dc (get-dc)]) (send dc suspend-flush) (send dc ensure-ready) @@ -156,7 +157,11 @@ (send dc set-background old-bg)))) (on-paint) (send dc resume-flush) - (queue-backing-flush)))) + (queue-backing-flush))] + [b ; => not shown to root + ;; invalidate dc so that it's refresh + ;; when it's shown again + (send (get-dc) reset-backing-retained)])) (when req (cancel-canvas-flush-delay req))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index eb19b784..b0beb092 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -41,6 +41,7 @@ (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) (define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) @@ -283,7 +284,7 @@ (set-size x y w h) - (define dc (new dc% [canvas this])) + (define dc (new dc% [canvas this] [transparent? (memq 'transparent style)])) (define for-gl? (memq 'gl style)) (when for-gl? @@ -344,10 +345,19 @@ (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) (define/override (internal-pre-on-event gtk e) - (when (and (ptr-equal? gtk combo-button-gtk) - (send e button-down?)) - (on-popup)) - #f) + (if (and (ptr-equal? gtk combo-button-gtk) + (send e button-down?)) + (begin + (on-popup) + #t) + #f)) + (define/public (popup-combo) + ;; Unfortunately, the user has to hold the mouse + ;; button down when popping up the menu this way, + ;; whereas the default handler (that we subvert in + ;; `internal-pre-on-event') keeps the menu open if + ;; the user release the mouse button right away. + (gtk_combo_box_popup gtk)) (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index ed66511f..383d23c7 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -92,11 +92,12 @@ (define dc% (class backing-dc% - (init [(cnvs canvas)]) + (init [(cnvs canvas)] + transparent?) (inherit end-delay) (define canvas cnvs) - (super-new) + (super-new [transparent? transparent?]) (define gl #f) (define/override (get-gl-context) @@ -146,12 +147,5 @@ [h (box 0)]) (send canvas get-client-size w h) (let ([cr (gdk_cairo_create win)]) - (let ([s (cairo_get_source cr)]) - (cairo_pattern_reference s) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 (unbox w) (unbox h)) - (cairo_fill cr) - (cairo_set_source cr s) - (cairo_pattern_destroy s)) + (backing-draw-bm bm cr (unbox w) (unbox h)) (cairo_destroy cr)))))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 92e3c78b..323e9964 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -47,6 +47,8 @@ (define HTHSCROLL 6) (define HTVSCROLL 7) +(define CB_SHOWDROPDOWN #x014F) + (define-cstruct _SCROLLINFO ([cbSize _UINT] [fMask _UINT] @@ -202,7 +204,7 @@ (define/override (wndproc-for-ctlproc w msg wParam lParam default) (default w msg wParam lParam)) - (define dc (new dc% [canvas this])) + (define dc (new dc% [canvas this] [transparent? (memq 'transparent style)])) (send dc start-backing-retained) (define/public (get-dc) dc) @@ -488,6 +490,9 @@ [(= cmd CBN_DROPDOWN) (constrained-reply (get-eventspace) (lambda () (on-popup)) (void))])) + (define/public (popup-combo) + (SendMessageW combo-hwnd CB_SHOWDROPDOWN 1 0)) + (define/override (is-hwnd? a-hwnd) (or (ptr-equal? panel-hwnd a-hwnd) (ptr-equal? canvas-hwnd a-hwnd) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index db260240..649e673d 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -63,11 +63,12 @@ (define dc% (class backing-dc% - (init [(cnvs canvas)]) + (init [(cnvs canvas)] + transparent?) (inherit end-delay) (define canvas cnvs) - (super-new) + (super-new [transparent? transparent?]) (define gl #f) (define/override (get-gl-context) @@ -116,14 +117,7 @@ (let* ([surface (cairo_win32_surface_create hdc)] [cr (cairo_create surface)]) (cairo_surface_destroy surface) - (let ([s (cairo_get_source cr)]) - (cairo_pattern_reference s) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 (unbox w) (unbox h)) - (cairo_fill cr) - (cairo_set_source cr s) - (cairo_pattern_destroy s)) + (backing-draw-bm bm cr (unbox w) (unbox h)) (cairo_destroy cr)))))) (define (request-flush-delay canvas) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index c87ae2ce..cb58ff65 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -22,16 +22,19 @@ (define children null) (define/override (register-child child on?) - (let ([now-on? (and (memq child children) #t)]) + (let ([on? (and on? #t)] + [now-on? (and (memq child children) #t)]) (unless (eq? on? now-on?) (unless on? (when (eq? child mouse-in-child) + (send child send-leaves #f) (set! mouse-in-child #f))) (set! children (if on? (cons child children) (remq child children))) - (send child parent-enable (is-enabled-to-root?))))) + (when on? + (send child parent-enable (is-enabled-to-root?)))))) (define/override (internal-enable on?) (super internal-enable on?) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index d89efe44..35b59e24 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -601,12 +601,13 @@ (define/public (send-leaves mk) (set! mouse-in? #f) - (let ([e (mk 'leave)]) - (if (eq? (current-thread) - (eventspace-handler-thread eventspace)) - (handle-mouse-event (get-client-hwnd) 0 0 e) - (queue-window-event this - (lambda () (dispatch-on-event/sync e)))))) + (when mk + (let ([e (mk 'leave)]) + (if (eq? (current-thread) + (eventspace-handler-thread eventspace)) + (handle-mouse-event (get-client-hwnd) 0 0 e) + (queue-window-event this + (lambda () (dispatch-on-event/sync e))))))) (define/public (send-child-leaves mk) #f) diff --git a/collects/mred/private/wxme/cycle.rkt b/collects/mred/private/wxme/cycle.rkt index ee30467e..05cc6dbd 100644 --- a/collects/mred/private/wxme/cycle.rkt +++ b/collects/mred/private/wxme/cycle.rkt @@ -8,7 +8,6 @@ (decl text% set-text%!) (decl pasteboard% set-pasteboard%!) -(decl snip-admin% set-snip-admin%!) (decl editor-stream-in% set-editor-stream-in%!) (decl editor-stream-out% set-editor-stream-out%!) (decl editor-snip% set-editor-snip%!) @@ -18,7 +17,6 @@ (decl extended-text% set-extended-text%!) (decl extended-pasteboard% set-extended-pasteboard%!) -(decl get-snip-class set-get-snip-class!) (decl get-editor-data-class set-get-editor-data-class!) (decl editor-get-file set-editor-get-file!) diff --git a/collects/mred/private/wxme/editor-admin.rkt b/collects/mred/private/wxme/editor-admin.rkt index 2a7e8cff..d3a701fb 100644 --- a/collects/mred/private/wxme/editor-admin.rkt +++ b/collects/mred/private/wxme/editor-admin.rkt @@ -1,8 +1,9 @@ #lang scheme/base (require scheme/class "../syntax.ss" - "snip.ss" + racket/snip "private.ss" + racket/snip/private/private (only-in "cycle.ss" popup-menu%)) (provide editor-admin%) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index 55542210..a12cbeeb 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -5,6 +5,7 @@ "editor.ss" "editor-admin.ss" "private.ss" + racket/snip/private/private (only-in "cycle.ss" popup-menu%) (only-in "../helper.ss" queue-window-callback) "wx.ss") diff --git a/collects/mred/private/wxme/editor-data.rkt b/collects/mred/private/wxme/editor-data.rkt new file mode 100644 index 00000000..a36182e4 --- /dev/null +++ b/collects/mred/private/wxme/editor-data.rkt @@ -0,0 +1,170 @@ +#lang racket/base + +(require scheme/class + scheme/file file/convertible + "../syntax.ss" + racket/snip/private/snip-flags + "private.ss" + racket/snip/private/private + "style.ss" + racket/snip/private/load-one + (only-in "cycle.ss" + editor-stream-in% editor-stream-out% + get-editor-data-class set-get-editor-data-class!) + "../wx/common/event.rkt" + racket/draw) + +(provide get-the-editor-data-class-list + editor-data% + editor-data-class% + location-editor-data% + editor-data-class-list<%> + the-editor-data-class-list ;; parameter + make-the-editor-data-class-list + (struct-out editor-data-class-link)) + +;; ------------------------------------------------------------ + +(defclass editor-data% object% + (properties [[(make-or-false editor-data-class%) dataclass] #f] + [[(make-or-false editor-data%) next] #f]) + (super-new) + (def/public (write [editor-stream-out% f]) + (error 'write "should have overridden")) + + (define/public (get-s-dataclass) dataclass) + (define/public (get-s-next) next) + (define/public (set-s-next v) (set! next v))) + + +(defclass location-editor-data% editor-data% + (inherit set-dataclass) + (init-field x y) + (super-new) + (set-dataclass the-location-editor-data-class) + + (define/public (get-x) x) + (define/public (get-y) y) + + (def/override (write [editor-stream-out% f]) + (send f put x) + (send f put y) + #t)) + +;; ------------------------------------------------------------ + +(defclass editor-data-class% object% + (define classname "wxbad") + (def/public (set-classname [string? s]) + (set! classname (string->immutable-string s))) + (def/public (get-classname) classname) + + (properties [[bool? required?] #f]) + (define/public (get-s-required?) required?) + + (def/public (read [editor-stream-in% f]) (void)) + + (super-new)) + +(defclass location-editor-data-class% editor-data-class% + (inherit set-classname + set-required?) + + (super-new) + + (set-classname "wxloc") + (set-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([x (send f get-inexact)] + [y (send f get-inexact)]) + (new location-editor-data% [x x][y y])))) + +(define the-location-editor-data-class + (new location-editor-data-class%)) + +;; ------------------------------------------------------------ + +(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position)) + +(defclass editor-data-class-list% object% + (define ht (make-hash)) + (define pos-ht (make-hash)) + (define rev-pos-ht (make-hash)) + + (super-new) + + (add the-location-editor-data-class) + + (def/public (find [string? name]) + (let ([c (hash-ref ht name #f)]) + (or c + (let ([c (get-editor-data-class name)]) + (when c (add c)) + c)))) + + (def/public (find-position [editor-data-class% c]) + (hash-ref pos-ht c 0)) + + (def/public (add [editor-data-class% c]) + (let ([name (send c get-classname)]) + (hash-set! ht name c) + (let ([n (add1 (hash-count pos-ht))]) + (hash-set! pos-ht c n) + (hash-set! rev-pos-ht n c)))) + + (def/public (number) (hash-count ht)) + + (def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f)) + + (def/public (write [editor-stream-out% f]) + (let ([n (number)]) + (send f put n) + (for ([i (in-range 1 (add1 n))]) + (let ([c (nth i)]) + (send f put (string->bytes/utf-8 (send c get-classname))) + + (send f add-dl (make-editor-data-class-link c + #f + i))))) + #t) + + (def/public (read [editor-stream-in% f]) + (let-boxes ([count 0]) + (send f get count) + (for/and ([i (in-range count)]) + (let ([s (send f get-bytes)]) + (and (send f ok?) + (send f add-dl (make-editor-data-class-link + #f + (bytes->string/utf-8 s #\?) + (add1 i))) + #t))))) + + (define/public (find-by-map-position f n) + (ormap (lambda (s) + (and (= n (editor-data-class-link-map-position s)) + (begin + (when (editor-data-class-link-name s) + (let ([c (find (editor-data-class-link-name s))]) + (when (not c) + ;; unknown class/version + (log-error (format "unknown editor data class: ~e" + (editor-data-class-link-name s)))) + (set-editor-data-class-link-name! s #f) + (set-editor-data-class-link-c! s c))) + (editor-data-class-link-c s)))) + (send f get-dl)))) + +(define editor-data-class-list<%> (class->interface editor-data-class-list%)) + +(define (make-the-editor-data-class-list) + (new editor-data-class-list%)) + +(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) +(define (get-the-editor-data-class-list) + (the-editor-data-class-list)) + +(set-get-editor-data-class! + (lambda (name) + (load-one name 'editor-data-class editor-data-class%))) diff --git a/collects/mred/private/wxme/editor-snip-class.rkt b/collects/mred/private/wxme/editor-snip-class.rkt new file mode 100644 index 00000000..05aa7c88 --- /dev/null +++ b/collects/mred/private/wxme/editor-snip-class.rkt @@ -0,0 +1,76 @@ +#lang racket/base + +(require racket/class + racket/file file/convertible + "../syntax.ss" + racket/snip/private/snip-flags + "private.ss" + racket/snip/private/private + "style.ss" + racket/snip + (only-in "cycle.ss" + editor-stream-in% editor-stream-out% + extended-text% extended-pasteboard% extended-editor-snip% + get-editor-data-class) + "../wx/common/event.rkt" + racket/draw) + +(provide the-editor-snip-class) +;; ------------------------------------------------------------ + +(defclass editor-snip-class% snip-class% + (inherit set-classname + set-version) + (inherit-field s-required?) + + (super-new) + + (set-classname "wxmedia") + (set-version 4) + (set! s-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([vers (send f do-reading-version this)]) + (let ([ed% (case (send f get-exact) + [(1) extended-text%] + [(2) extended-pasteboard%] + [else #f])] + [border? (positive? (send f get-exact))] + [lm (max 0 (send f get-exact))] + [tm (max 0 (send f get-exact))] + [rm (max 0 (send f get-exact))] + [bm (max 0 (send f get-exact))] + [li (max 0 (send f get-exact))] + [ti (max 0 (send f get-exact))] + [ri (max 0 (send f get-exact))] + [bi (max 0 (send f get-exact))] + [min-w (send f get-inexact)] + [max-w (send f get-inexact)] + [min-h (send f get-inexact)] + [max-h (send f get-inexact)] + [tf? (and (vers . > . 1) + (positive? (send f get-exact)))] + [atl? (and (vers . > . 2) + (positive? (send f get-exact)))] + [ubs? (and (vers . > . 3) + (positive? (send f get-exact)))]) + (let ([e (and ed% (new ed%))]) + (let ([snip (make-object extended-editor-snip% + e + border? + lm tm rm bm li ti ri bi + (if (negative? min-w) 'none min-w) + (if (negative? max-w) 'none max-w) + (if (negative? min-h) 'none min-h) + (if (negative? max-h) 'none max-h))]) + (send snip do-set-graphics tf? atl? ubs?) + (if e + (begin + (send e get-style-list) + (send e read-from-file f #t)) + (send snip set-editor #f)) + snip)))))) + +(define the-editor-snip-class (new editor-snip-class%)) + +(send (get-the-snip-class-list) add the-editor-snip-class) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 0c74ec30..538079b6 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -2,12 +2,14 @@ (require scheme/class "../syntax.ss" "private.ss" + racket/snip/private/private "const.ss" - "snip.ss" - "snip-flags.ss" + racket/snip + racket/snip/private/snip-flags + "standard-snip-admin.rkt" "editor.ss" "editor-admin.ss" - "snip-admin.ss" + "editor-snip-class.rkt" "text.ss" "pasteboard.ss" "wx.ss" @@ -15,8 +17,7 @@ text% pasteboard% editor-snip% - editor-snip-editor-admin% - snip-admin%)) + editor-snip-editor-admin%)) (provide editor-snip% editor-snip-editor-admin<%>) @@ -360,8 +361,8 @@ (when with-border? (let ([pen (send dc get-pen)]) (when (and (pair? caret) - selected-text-color) - (send dc set-pen selected-text-color 1 'solid)) + (send my-admin get-selected-text-color)) + (send dc set-pen (send my-admin get-selected-text-color) 1 'solid)) (let* ([l (+ orig-x left-inset)] [t (+ orig-y top-inset)] [r (+ l w left-margin right-margin diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 4cffb161..74c99bbb 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -4,13 +4,15 @@ scheme/file "../syntax.ss" "private.ss" + racket/snip/private/private "style.ss" - "snip.ss" - "snip-flags.ss" + racket/snip + racket/snip/private/snip-flags "editor-admin.ss" "stream.ss" "undo.ss" "keymap.ss" + "editor-data.rkt" (only-in "cycle.ss" text% pasteboard% diff --git a/collects/mred/private/wxme/mline.rkt b/collects/mred/private/wxme/mline.rkt index 0677b61e..f3f2809b 100644 --- a/collects/mred/private/wxme/mline.rkt +++ b/collects/mred/private/wxme/mline.rkt @@ -2,9 +2,10 @@ (require scheme/class "../syntax.ss" "const.ss" - "snip.ss" - "snip-flags.ss" - "private.ss") + racket/snip + racket/snip/private/snip-flags + "private.ss" + racket/snip/private/private) (provide create-mline (struct-out mline) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4bb1e8d7..1cb11b08 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -5,12 +5,14 @@ "../syntax.ss" "const.ss" "private.ss" + racket/snip/private/private "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" - "snip.ss" - "snip-flags.ss" - "snip-admin.ss" + racket/snip + racket/snip/private/snip-flags + "standard-snip-admin.rkt" "keymap.ss" (only-in "cycle.ss" set-pasteboard%!) "wordbreak.ss" diff --git a/collects/mred/private/wxme/private.rkt b/collects/mred/private/wxme/private.rkt index ddfd3642..852ad3b1 100644 --- a/collects/mred/private/wxme/private.rkt +++ b/collects/mred/private/wxme/private.rkt @@ -3,44 +3,11 @@ (provide (all-defined-out)) -;; snip% and editor% -(define-local-member-name - s-admin) - -;; snip% -(define-local-member-name - s-prev set-s-prev - s-next set-s-next - s-count - s-style set-s-style - s-line set-s-line - s-snipclass set-s-snipclass - s-flags set-s-flags - s-dtext get-s-dtext - s-buffer get-s-buffer - str-w set-str-w - s-set-flags - do-copy-to) - -;; string-snip% -(define-local-member-name - insert-with-offset) - -;; snip-class% -(define-local-member-name - get-s-required? - s-read) - ;; editor-data% (define-local-member-name get-s-dataclass get-s-next) -;; standard-snip-class-list%, editor-data-class-list% -(define-local-member-name - reset-header-flags - find-by-map-position) - ;; editor% (define-local-member-name s-offscreen @@ -111,25 +78,6 @@ do-get-canvas do-scroll-to) -;; editor-stream% -(define-local-member-name - get-sl - get-dl - set-sl - set-dl - add-sl - add-dl - set-s-sll - get-s-sll - get-s-scl - get-s-bdl - get-s-style-count - set-s-style-count - do-reading-version - do-map-position - do-get-header-flag - do-set-header-flag) - ;; editor-stream-in% (define-local-member-name set-s-read-format diff --git a/collects/mred/private/wxme/snip-admin.rkt b/collects/mred/private/wxme/standard-snip-admin.rkt similarity index 73% rename from collects/mred/private/wxme/snip-admin.rkt rename to collects/mred/private/wxme/standard-snip-admin.rkt index f794387d..b2af3161 100644 --- a/collects/mred/private/wxme/snip-admin.rkt +++ b/collects/mred/private/wxme/standard-snip-admin.rkt @@ -1,56 +1,15 @@ #lang scheme/base (require scheme/class "../syntax.ss" - "snip.ss" + racket/snip (only-in "cycle.ss" - set-snip-admin%! popup-menu%) - "wx.ss") + (prefix-in wx: "wx.ss")) -(provide snip-admin% - standard-snip-admin%) +(provide standard-snip-admin%) -(defclass snip-admin% object% - (super-new) +(define TAB-WIDTH 20) - (def/public (get-editor) #f) - (def/public (get-dc) #f) - (def/public (get-view-size [maybe-box? w] [maybe-box? h]) - #f) - - (def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] - [(make-or-false snip%) [snip #f]]) - #f) - - (def/public (scroll-to [snip% s] - [real? x] [real? y] - [nonnegative-real? w] [nonnegative-real? h] - [any? refresh?] - [(symbol-in start end none) [bias 'none]]) - #f) - - (def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist]) - (void)) - - (def/public (resized [snip% s] [any? redraw?]) (void)) - - (def/public (recounted [snip% s] [any? redraw?]) (void)) - - (def/public (needs-update [snip% s] [real? x] [real? y] - [nonnegative-real? w] [nonnegative-real? h]) - (void)) - - (def/public (release-snip [snip% s]) #f) - - (def/public (update-cursor) (void)) - - (def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y]) - #f) - - (def/public (modified [snip% s] [any? modified?]) - (void))) - -(set-snip-admin%! snip-admin%) (defclass standard-snip-admin% snip-admin% (init-field editor) @@ -146,4 +105,27 @@ (def/override (modified [snip% s] [any? modified?]) (when (eq? (send s get-admin) this) - (send editor on-snip-modified s modified?)))) + (send editor on-snip-modified s modified?))) + + (def/override (get-line-spacing) + (if (object-method-arity-includes? editor 'get-line-spacing 0) + (send editor get-line-spacing) + 0)) + + (def/override (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]]) + (if (object-method-arity-includes? editor 'get-tabs 3) + (send editor get-tabs length tab-width in-units) + (begin (when length (set-box! length 0)) + (when tab-width (set-box! tab-width TAB-WIDTH)) + (when in-units (set-box! in-units #t)) + null))) + + (def/override (get-selected-text-color) + (wx:get-highlight-text-color)) + + (def/override (call-with-busy-cursor [procedure? thunk]) + (dynamic-wind + wx:begin-busy-cursor + thunk + wx:end-busy-cursor)) + ) diff --git a/collects/mred/private/wxme/stream.rkt b/collects/mred/private/wxme/stream.rkt index 429fb9f5..2828e01c 100644 --- a/collects/mred/private/wxme/stream.rkt +++ b/collects/mred/private/wxme/stream.rkt @@ -2,7 +2,9 @@ (require scheme/class "../syntax.ss" "private.ss" - "snip.ss" + racket/snip/private/private + racket/snip + "editor-data.rkt" (only-in "cycle.ss" set-editor-stream-in%! set-editor-stream-out%!)) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index be32c886..a71ff6d9 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -7,12 +7,14 @@ "const.ss" "mline.ss" "private.ss" + racket/snip/private/private "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" - "snip.ss" - "snip-flags.ss" - "snip-admin.ss" + racket/snip + racket/snip/private/snip-flags + "standard-snip-admin.rkt" "keymap.ss" (only-in "cycle.ss" set-text%!) "wordbreak.ss" @@ -5106,7 +5108,22 @@ (lambda () (call-on-paint #f) (set! write-locked? wl?) - (set! flow-locked? #f))]) + (set! flow-locked? #f))] + + [local-caret-pen + (if bg-color + (let ([r (send bg-color red)] + [g (send bg-color green)] + [b (send bg-color blue)]) + (if (and (= r 255) (= g 255) (= b 255)) + caret-pen + (make-object pen% (make-object color% + (- 255 r) + (- 255 g) + (- 255 b)) + (send caret-pen get-width) + 'solid))) + caret-pen)]) (call-on-paint #t) @@ -5132,7 +5149,7 @@ hilite-on?) (let ([y ycounter] [save-pen (send dc get-pen)]) - (send dc set-pen caret-pen) + (send dc set-pen local-caret-pen) (send dc draw-line dx (+ y dy) dx (sub1 (+ y extra-line-h dy))) (send dc set-pen save-pen))) (paint-done)] @@ -5312,7 +5329,7 @@ (when (eq? 'show-caret show-caret) (when (and (hsxs . <= . rightx) (hsxs . >= . leftx)) (let ([save-pen (send dc get-pen)]) - (send dc set-pen caret-pen) + (send dc set-pen local-caret-pen) (send dc draw-line (+ hsxs dx) (+ hsys dy) (+ hsxs dx) (+ hsye (sub1 dy))) diff --git a/collects/mred/private/wxme/undo.rkt b/collects/mred/private/wxme/undo.rkt index 053b3f82..f8c36258 100644 --- a/collects/mred/private/wxme/undo.rkt +++ b/collects/mred/private/wxme/undo.rkt @@ -1,8 +1,9 @@ #lang scheme/base (require scheme/class "private.ss" - "snip.ss" - "snip-flags.ss") + racket/snip/private/private + racket/snip + racket/snip/private/snip-flags) (provide change-record% proc-record% diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index fd248acf..4ab20d6c 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -1,22 +1,14 @@ #lang scheme/base -(require "../kernel.ss") +(require "../kernel.ss" "symbol-predicates.rkt") (define the-clipboard (get-the-clipboard)) (define the-x-selection-clipboard (get-the-x-selection)) -(define (family-symbol? s) - (memq s '(default decorative roman script - swiss modern symbol system))) -(define (style-symbol? s) - (memq s '(normal italic slant))) -(define (weight-symbol? s) - (memq s '(normal bold light))) -(define (smoothing-symbol? s) - (memq s '(default smoothed unsmoothed partly-smoothed))) (define (size? v) (and (exact-positive-integer? v) (byte? v))) -(provide event% +(provide (all-from-out "symbol-predicates.rkt") + event% mouse-event% key-event% timer% diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 6f4c7f39..893ee6f7 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -3,7 +3,7 @@ mzlib/class100 (prefix-in wx: "kernel.ss") (prefix-in wx: "wxme/text.ss") - (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: racket/snip) (prefix-in wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" @@ -221,6 +221,7 @@ (private-field [l (and label (make-object wx-message% #f proxy p label -1 -1 null font))] + [combo-callback #f] [c (make-object (class wx-text-editor-canvas% (define/override (on-combo-select i) (let ([len (length callbacks)]) @@ -239,8 +240,31 @@ '(hide-hscroll)) '(hide-vscroll hide-hscroll))))] [callbacks null]) + (override + [pre-on-event (lambda (w e) + (or (super pre-on-event w e) + (and combo-callback + (eq? w c) + (send e button-down?) + (let ([w (box 0)] + [h (box 0)]) + (send c get-client-size w h) + (not (and (<= 0 (send e get-x) (unbox w)) + (<= 0 (send e get-y) (unbox h))))) + (begin + (do-popup-callback) + #t))))]) + (private + [do-popup-callback (lambda () + (wx:queue-callback (lambda () + (when (send c is-enabled-to-root?) + (combo-callback) + (send c popup-combo))) + wx:middle-queue-key))]) (public - [set-on-popup (lambda (proc) (send c set-on-popup proc))] + [set-on-popup (lambda (proc) + (set! combo-callback proc) + (send c set-on-popup (lambda () (do-popup-callback))))] [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))] [append-combo-item (lambda (s cb) (and (send c append-combo-item s) diff --git a/collects/mrlib/cache-image-snip.rkt b/collects/mrlib/cache-image-snip.rkt index 0e37ec1d..1f26d096 100644 --- a/collects/mrlib/cache-image-snip.rkt +++ b/collects/mrlib/cache-image-snip.rkt @@ -1,5 +1,6 @@ (module cache-image-snip mzscheme - (require mred + (require racket/draw + racket/snip mzlib/class mzlib/string mzlib/contract diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index bab19783..1d8fdfda 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -28,15 +28,17 @@ has been moved out). |# (require racket/class - racket/gui/base + racket/draw + (for-syntax racket/base) + file/convertible racket/math racket/contract - "private/image-core-bitmap.ss" + "private/image-core-bitmap.ss" "image-core-wxme.ss" "private/image-core-snipclass.rkt" "private/regmk.rkt" - (prefix-in cis: "cache-image-snip.ss") - (for-syntax racket/base)) + racket/snip + (prefix-in cis: "cache-image-snip.ss")) @@ -197,8 +199,31 @@ has been moved out). (define skip-image-equality-fast-path (make-parameter #f)) (define render-normalized (make-parameter #f)) +(define png-convertible<%> + (interface* () + ([prop:convertible + (lambda (img format default) + (case format + [(png-bytes) + (let ([s (open-output-bytes)]) + (send (to-bitmap (to-img img)) save-file s 'png) + (get-output-bytes s))] + [else default]))]))) + +(define (to-bitmap img) + (let* ([bb (send img get-bb)] + [bm (make-bitmap + (add1 (inexact->exact (ceiling (bb-right bb)))) + (add1 (inexact->exact (ceiling (bb-bottom bb)))))] + [bdc (new bitmap-dc% [bitmap bm])]) + (send bdc clear) + (render-image img bdc 0 0) + (begin0 + (send bdc get-bitmap) + (send bdc set-bitmap #f)))) + (define image% - (class* snip% (equal<%> image<%>) + (class* snip% (png-convertible<%> equal<%> image<%>) (init-field shape bb normalized? pinhole) (define/public (equal-to? that eq-recur) (or (eq? this that) @@ -260,10 +285,7 @@ has been moved out). (when standard (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]) (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))]) - (set! scroll-step (+ h - (if (is-a? ed text%) - (send ed get-line-spacing) - 0))))))))) + (set! scroll-step (+ h (send admin get-line-spacing))))))))) ;; if that didn't happen, set it to 12. (unless scroll-step (set! scroll-step 12)))) @@ -280,8 +302,7 @@ has been moved out). (define/override (copy) (make-image shape bb normalized? pinhole)) (define/override (draw dc x y left top right bottom dx dy draw-caret?) - (let ([smoothing (send dc get-smoothing)]) - (render-image this dc x y))) + (render-image this dc x y)) (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) (send (get-the-snip-class-list) add snip-class) @@ -1146,7 +1167,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image) + image-snip->image + image-snip%) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 949acdcb..9b694af2 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/gui/base +(require racket/draw scheme/class) diff --git a/collects/mrlib/switchable-button.rkt b/collects/mrlib/switchable-button.rkt index 85e795d9..7700c0dd 100644 --- a/collects/mrlib/switchable-button.rkt +++ b/collects/mrlib/switchable-button.rkt @@ -88,7 +88,8 @@ (define/override (on-superwindow-show show?) (unless show? (set! in? #f) - (set! down? #f)) + (set! down? #f) + (refresh)) (super on-superwindow-show show?)) (define/override (on-event evt) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index be13bbe9..43d1da29 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -55,8 +55,9 @@ The @scheme[style] argument indicates one or more of the following styles: canvas before calls to @method[canvas% on-paint]} @item{@scheme['transparent] --- the canvas is automatically ``erased'' - before an update using it's parent window's background; the result is - undefined if this flag is combined with @scheme['no-autoclear]} + before an update using it's parent window's background; see @racket[canvas<%>] + for information on the interaction of @racket['transparent] and offscreen buffering; + the result is undefined if this flag is combined with @scheme['no-autoclear]} @item{@scheme['no-focus] --- prevents the canvas from accepting the keyboard focus when the canvas is clicked, or when the diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index e802de77..411d9b8f 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -6,9 +6,6 @@ A canvas is a subwindow onto which graphics and text can be drawn. Canvases also receive mouse and keyboard events. -To draw onto a canvas, get its device context (see -@method[canvas<%> get-dc]). - The @scheme[canvas<%>] interface is implemented by two classes: @itemize[ @@ -20,6 +17,28 @@ The @scheme[canvas<%>] interface is implemented by two classes: ] +To draw onto a canvas, get its device context (see +@method[canvas<%> get-dc]). + +Drawing to a canvas's drawing context actually renders into an +offscreen buffer. The buffer is automatically flushed to the screen by +a background thread, explicitly via the @method[canvas<%> flush] +method, or explicitly via @racket[flush-display]---unless flushing +has been disabled for the canvas. The @method[canvas<%> +suspend-flush] method suspends flushing for a canvas until a matching +@method[canvas<%> resume-flush] calls; calls to @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] can be nested, in +which case flushing is suspended until the outermost @method[canvas<%> +suspend-flush] is balanced by a @method[canvas<%> resume-flush]. + +In the case of a transparent canvas (i.e., one that is created with +@racket['transparent] style), line and text smoothing can depend on +the window that serves as the canvas's background. For example, +smoothing may color pixels differently depending on whether the target +context is white or gray. Background-sensitive smoothing is supported +only if a relatively small number of drawing commands are recorded in +the canvas's offscreen buffer, however. + @defmethod*[([(accept-tab-focus) boolean?] @@ -191,7 +210,7 @@ Does nothing. @defmethod[(resume-flush) void?]{ -See @method[canvas<%> suspend-flush].} +See @racket[canvas<%>] for information on canvas flushing.} @@ -223,19 +242,10 @@ Under Mac OS X, enables or disables space for a resize tab at the @defmethod[(suspend-flush) void?]{ -Drawing to a canvas's drawing context actually renders into an -offscreen buffer. The buffer is automatically flushed to the screen by -a background thread, explicitly via the @method[canvas<%> flush] method, -or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas. -The @method[canvas<%> suspend-flush] method suspends flushing for a -canvas until a matching @method[canvas<%> resume-flush] calls; calls to -@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can -be nested, in which case flushing is suspended until the outermost -@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%> -resume-flush]. +See @racket[canvas<%>] for information on canvas flushing. -On some platforms, beware that suspending flushing for a canvas can -discourage refreshes for other windows in the same frame.} +Beware that suspending flushing for a canvas can discourage refreshes +for other windows in the same frame on some platforms.} @defmethod[(warp-pointer [x (integer-in 0 10000)] diff --git a/collects/scribblings/gui/diagrams.rkt b/collects/scribblings/gui/diagrams.rkt index 962a2b99..4479eccc 100644 --- a/collects/scribblings/gui/diagrams.rkt +++ b/collects/scribblings/gui/diagrams.rkt @@ -11,8 +11,10 @@ menu-diagram editor-diagram snip-diagram + editor-snip-diagram style-diagram - admin-diagram + snip-list-diagram + editor-admin-diagram stream-diagram) (define (diagram->table d) @@ -125,11 +127,21 @@ DIAG |- string-snip% | |- tab-snip% |- image-snip% + |- editor-snip% (not provided by racket/snip) + + snip-admin% +DIAG +) + + (define editor-snip-diagram +#< style-delta% add-color<%> style-list% mult-color<%> DIAG +) + + (define snip-list-diagram +#< +DIAG ) (define stream-diagram #< snip-class-list<%> + editor-data-class% + editor-data-class-list<%> editor-stream-in% editor-stream-out% editor-stream-in-base% editor-stream-out-base% diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index f0bf8589..4b6e24bd 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -71,7 +71,9 @@ The @scheme[style] list can contain the following flags: method} @item{@scheme['transparent] --- the canvas is ``erased'' before an - update using its parent window's background} + update using its parent window's background; see @racket[canvas<%>] + for information on the interaction of @racket['transparent] and + offscreen buffering} ] diff --git a/collects/scribblings/gui/editor-classes.scrbl b/collects/scribblings/gui/editor-classes.scrbl index 5e29f050..c90bd8b3 100644 --- a/collects/scribblings/gui/editor-classes.scrbl +++ b/collects/scribblings/gui/editor-classes.scrbl @@ -8,13 +8,13 @@ Editors: @diagram->table[editor-diagram] -Snips: +Editor Snips: -@diagram->table[snip-diagram] +@diagram->table[editor-snip-diagram] Displays, Administrators, and Mappings: -@diagram->table[admin-diagram] +@diagram->table[editor-admin-diagram] Styles: @@ -44,18 +44,10 @@ Alphabetical: @include-section["editor-stream-out-base-class.scrbl"] @include-section["editor-stream-out-bytes-base-class.scrbl"] @include-section["editor-wordbreak-map-class.scrbl"] -@include-section["image-snip-class.scrbl"] @include-section["keymap-class.scrbl"] @include-section["mult-color-intf.scrbl"] @include-section["pasteboard-class.scrbl"] -@include-section["readable-snip-intf.scrbl"] -@include-section["snip-class.scrbl"] -@include-section["snip-admin-class.scrbl"] -@include-section["snip-class-class.scrbl"] -@include-section["snip-class-list-intf.scrbl"] -@include-section["string-snip-class.scrbl"] @include-section["style-intf.scrbl"] @include-section["style-delta-class.scrbl"] @include-section["style-list-class.scrbl"] -@include-section["tab-snip-class.scrbl"] @include-section["text-class.scrbl"] diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index b51741fe..fa3be7dc 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -43,6 +43,7 @@ Both parts of the toolbox rely extensively on the @include-section["win-classes.scrbl"] @include-section["win-funcs.scrbl"] @include-section["editor-overview.scrbl"] +@include-section["snip-classes.scrbl"] @include-section["editor-classes.scrbl"] @include-section["editor-funcs.scrbl"] @include-section["wxme.scrbl"] diff --git a/collects/scribblings/gui/snip-admin-class.scrbl b/collects/scribblings/gui/snip-admin-class.scrbl index 1f3f152e..cf0a8f4c 100644 --- a/collects/scribblings/gui/snip-admin-class.scrbl +++ b/collects/scribblings/gui/snip-admin-class.scrbl @@ -320,4 +320,70 @@ Queues an update for the cursor in the @techlink{display} for this Does nothing. -}}} +}} + + +@defmethod[(get-line-spacing) + (and/c real? (not/c negative?))]{ + +@methspec{ + +Returns the spacing inserted by the snip's editor between each +line. +} +@methimpl{ + +Returns @scheme[0.0] + +}} + +@defmethod[(get-selected-text-color) + void?]{ + +@methspec{ + +Returns the color that is used to draw selected text or @scheme[#f] if +selected text is drawn with its usual color. +} +@methimpl{ + +Returns @scheme[#f]. +}} + + +@defmethod[(call-with-busy-cursor [thunk (-> any)]) + any]{ + +@methspec{ + +Calls @scheme[thunk] while changing the cursor to a watch cursor for +all windows in the current eventspace. + +} + +@methimpl{ + +Does nothing. +}} + +@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) #f) #f] + [tab-width (or/c (box/c real?) #f) #f] + [in-units (or/c (box/c any/c) #f) #f]) + (listof real?)]{ + +@methspec{ +Returns the current tab-position array as a list. + +@boxisfillnull[(scheme length) @elem{the length of the tab array (and therefore the returned +list)}] +@boxisfillnull[(scheme tab-width) @elem{the width used for tabs past the +end of the tab array}] +@boxisfillnull[(scheme in-units) @elem{@scheme[#t] if the tabs are specified in +canvas units or @scheme[#f] if they are specified in space-widths}] +} + +@methimpl{ +Returns @scheme[null]. +} +} +} \ No newline at end of file diff --git a/collects/scribblings/gui/snip-classes.scrbl b/collects/scribblings/gui/snip-classes.scrbl new file mode 100644 index 00000000..6afe9a3d --- /dev/null +++ b/collects/scribblings/gui/snip-classes.scrbl @@ -0,0 +1,32 @@ +#lang scribble/doc +@(require "common.ss" + "diagrams.ss") + +@title[#:style '(toc quiet)]{Snip Classes} + +@;@defmodule*/no-declare[(racket/snip)] + +The @racketmodname[racket/snip] collection provides access to the +@tech{snip} classes @emph{without} depending on +@racketmodname[racket/gui]. + +Snips and Administrators: + +@diagram->table[snip-diagram] + +Snip Lists: + +@diagram->table[snip-list-diagram] + +Alphabetical: + +@local-table-of-contents[] + +@include-section["image-snip-class.scrbl"] +@include-section["readable-snip-intf.scrbl"] +@include-section["snip-class.scrbl"] +@include-section["snip-admin-class.scrbl"] +@include-section["snip-class-class.scrbl"] +@include-section["snip-class-list-intf.scrbl"] +@include-section["string-snip-class.scrbl"] +@include-section["tab-snip-class.scrbl"] diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 7213989f..de0a8ebc 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -218,6 +218,88 @@ (send bm3 get-argb-pixels 0 0 70 70 s3) (test #t 'same-scaled (equal? s2 s3)))) +;; ---------------------------------------- +;; Test some masking combinations + +(let () + (define u (make-object bitmap% 2 2)) + (define mu (make-object bitmap% 2 2)) + (send u set-argb-pixels 0 0 2 2 + (bytes 255 100 0 0 + 255 0 0 0 + 255 100 0 0 + 255 255 255 255)) + (send mu set-argb-pixels 0 0 2 2 + (bytes 255 0 0 0 + 255 255 255 255 + 255 0 0 0 + 255 255 255 255)) + (send u set-loaded-mask mu) + (define (try-draw nonce-color mode expect + #:bottom? [bottom? #f]) + (let* ((b&w? (not (eq? mode 'color))) + (bm (make-object bitmap% 2 2 b&w?)) + (dc (make-object bitmap-dc% bm))) + (send dc clear) + (when (eq? mode 'black) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 2 2)) + ;; Check that draw-bitmap-section really uses the + ;; section, even in combination with a mask. + (send dc draw-bitmap-section u + 0 (if bottom? 1 0) + 0 (if bottom? 1 0) 2 1 + 'solid nonce-color (send u get-loaded-mask)) + (send dc set-bitmap #f) + (let ([s (make-bytes (* 2 2 4))]) + (send bm get-argb-pixels 0 0 2 2 s) + (when b&w? (send bm get-argb-pixels 0 0 2 2 s #t)) + (test expect 'masked-draw s)))) + (define usual-expect (bytes 255 100 0 0 + 255 255 255 255 + 255 255 255 255 + 255 255 255 255)) + (try-draw (make-object color% "green") 'color usual-expect) + (try-draw (make-object color%) 'color usual-expect) + (try-draw (make-object color%) 'white + ;; For b&w destination, check that the + ;; alpha is consistent with the drawn pixels + (bytes 255 0 0 0 + 0 255 255 255 + 0 255 255 255 + 0 255 255 255)) + (send mu set-argb-pixels 0 0 2 2 + (bytes 255 255 255 255 + 255 255 255 255 + 255 0 0 0 + 255 0 0 0)) + (try-draw (make-object color%) 'black + #:bottom? #t + ;; Another b&w destination test, this time + ;; with a mask that forces black pixels to + ;; white: + (bytes 255 0 0 0 + 255 0 0 0 + 255 0 0 0 + 0 255 255 255)) + (send mu set-argb-pixels 0 0 2 2 + (bytes 255 255 255 255 + 255 0 0 0 + 255 255 255 255 + 255 0 0 0)) + (try-draw (make-object color%) 'color + (bytes 255 255 255 255 + 255 0 0 0 + 255 255 255 255 + 255 255 255 255)) + (let ([dc (make-object bitmap-dc% mu)]) + (send dc erase) + (send dc set-pen "white" 1 'transparent) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 1 1) + (send dc set-bitmap #f)) + (try-draw (make-object color%) 'color usual-expect)) + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 3d8158cb..f885c00e 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -660,7 +660,9 @@ ; Bitmap copying: (when (and (not no-bitmaps?) last?) (let ([x 5] [y 165]) - (let ([mred-icon (get-icon)]) + (let ([bg (send dc get-background)] + [mred-icon (get-icon)]) + (send dc set-background "YELLOW") (case mask-ex-mode [(plt plt-mask plt^plt mred^plt) (let* ([plt (get-plt)] @@ -711,19 +713,20 @@ mred-icon)] [(mred~) (send dc draw-bitmap (get-rotated) x y 'opaque)] - [(mred^mred~ opaque-mred^mred~ red-mred^mred~) + [(mred^mred~ opaque-mred^mred~ red-mred^mred~ opaque-red-mred^mred~) (send dc draw-bitmap mred-icon x y - (if (eq? mask-ex-mode 'opaque-mred^mred~) + (if (memq mask-ex-mode '(opaque-mred^mred~ opaque-red-mred^mred~)) 'opaque 'solid) (send the-color-database find-color - (if (eq? mask-ex-mode 'red-mred^mred~) + (if (memq mask-ex-mode '(red-mred^mred~ opaque-red-mred^mred~)) "RED" "BLACK")) (get-rotated))] [else ;; simple draw - (send dc draw-bitmap mred-icon x y 'xor)])) + (send dc draw-bitmap mred-icon x y 'xor)]) + (send dc set-background bg)) (set! x (+ x (send (get-icon) get-width))) (let ([black (send the-color-database find-color "BLACK")] [red (send the-color-database find-color "RED")] @@ -1191,13 +1194,14 @@ (make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f))) (make-object choice% #f '("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd" - "MrEd~" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red" + "MrEd~ Opaque" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red" "M^M~ Rd Opq" "PLT^PLT") hp2.5 (lambda (self event) (send canvas set-mask-ex-mode (list-ref '(mred plt plt-mask mred^plt mred^mred - mred~ mred^mred~ opaque-mred^mred~ red-mred^mred~ + mred~ mred^mred~ opaque-mred^mred~ + red-mred^mred~ opaque-red-mred^mred~ plt^plt) (send self get-selection))))) (make-object check-box% "Kern" hp2.5 diff --git a/collects/tests/gracket/wxme.rkt b/collects/tests/gracket/wxme.rkt index 63a03db2..a5d3c73e 100644 --- a/collects/tests/gracket/wxme.rkt +++ b/collects/tests/gracket/wxme.rkt @@ -7,7 +7,7 @@ clipboard-client% key-event% mouse-event%) - mred/private/wxme/snip + racket/snip mred/private/wxme/mline mred/private/wxme/style mred/private/wxme/editor