From 3cb7594793d690d9898776051741205f9953e6a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Jun 2010 12:32:05 -0600 Subject: [PATCH] mostly tab-panel and mnemonic repairs --- collects/mred/private/mrpanel.rkt | 3 +- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/list-box.rkt | 7 +- collects/mred/private/wx/cocoa/radio-box.rkt | 6 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 54 ++++++++++-- collects/mred/private/wx/common/procs.rkt | 8 +- collects/mred/private/wx/gtk/button.rkt | 9 +- collects/mred/private/wx/gtk/check-box.rkt | 4 +- collects/mred/private/wx/gtk/list-box.rkt | 89 ++++++++++++++++---- collects/mred/private/wx/gtk/message.rkt | 29 ++++++- collects/mred/private/wx/gtk/tab-panel.rkt | 79 ++++++++++++++--- collects/mred/private/wxlitem.rkt | 2 +- 12 files changed, 238 insertions(+), 54 deletions(-) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 0fa10e39fb..34c494af79 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -135,7 +135,8 @@ (check-font cwho font)) (super-init parent (if (memq 'deleted style) '(deleted) - null))) + null)) + (send (mred->wx this) set-callback callback)) (public [get-number (lambda () (length save-choices))] diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 3b6fe436db..93ec7a9dbd 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -46,7 +46,7 @@ NSRoundedBezelStyle))) (cond [(string? label) - (tellv cocoa setTitle: #:type _NSString label)] + (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] [(send label ok?) (if button-type (tellv cocoa setTitle: #:type _NSString "") diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index aa3115e331..fa855e309e 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -122,9 +122,10 @@ (tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) (define/public (set-string i s) - (append (take items i) - (list s) - (drop items (add1 i))) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) (reset)) (define/public (number) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 88db164233..d2a6df580c 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -90,9 +90,9 @@ (begin (tellv button setTitle: #:type _NSString "") (set-ivar! button img (bitmap->image label))) - (tellv button setTitle: #:type _NSString (if (string? label) - label - ""))) + (tellv button setTitleWithMnemonic: #:type _NSString (if (string? label) + label + ""))) (tellv button setButtonType: #:type _int NSRadioButton))) (tellv cocoa sizeToFit) (tellv cocoa setTarget: cocoa) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index fa2f440cc1..3548c163a9 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -6,13 +6,22 @@ "types.rkt" "utils.rkt" "window.rkt" - "panel.rkt") + "panel.rkt" + "../common/event.rkt" + "../common/procs.rkt") (unsafe!) (objc-unsafe!) (provide tab-panel%) (import-class NSView NSTabView NSTabViewItem) +(import-protocol NSTabViewDelegate) + +(define-objc-class MyTabView NSTabView + #:protocols (NSTabViewDelegate) + [wx] + (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) + (queue-window-event wx (lambda () (send wx do-callback))))) (defclass tab-panel% (panel-mixin window%) (init parent @@ -22,16 +31,17 @@ (inherit get-cocoa) (define cocoa (as-objc-allocation - (tell (tell NSTabView alloc) init))) + (tell (tell MyTabView alloc) init))) (define item-cocoas (for/list ([lbl (in-list labels)]) (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) - (tellv item setLabel: #:type _NSString lbl) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) (tellv cocoa addTabViewItem: item) item))) (let ([sz (tell #:type _NSSize cocoa minimumSize)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) sz))) + (tellv cocoa setDelegate: cocoa) (define content-cocoa (as-objc-allocation @@ -45,10 +55,44 @@ (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect))) (define/public (set-label i str) - (tellv (list-ref item-cocoas i) setLabel: #:type _NSString str)) - + (tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str))) + (define/public (set-selection i) (tellv cocoa selectTabViewItem: (list-ref item-cocoas i))) + (define/public (get-selection) + (item->index (tell cocoa selectedTabViewItem))) + + (define (item->index tv) + (for/or ([c (in-list item-cocoas)] + [i (in-naturals)]) + (and (ptr-equal? c tv) i))) + + (public [append* append]) + (define (append* lbl) + (let ([item (as-objc-allocation + (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv cocoa addTabViewItem: item) + (set! item-cocoas (append item-cocoas (list item))))) + + (define/public (delete i) + (let ([item-cocoa (list-ref item-cocoas i)]) + (tellv cocoa removeTabViewItem: item-cocoa) + (set! item-cocoas (remq item-cocoa item-cocoas)))) + + (define/public (set choices) + (for ([item-cocoa (in-list item-cocoas)]) + (tellv cocoa removeTabViewItem: item-cocoa)) + (set! item-cocoas null) + (for ([lbl (in-list choices)]) + (append* lbl))) + + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/public (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) (super-new [parent parent] [cocoa cocoa] diff --git a/collects/mred/private/wx/common/procs.rkt b/collects/mred/private/wx/common/procs.rkt index f28ba4a80c..362911fc6d 100644 --- a/collects/mred/private/wx/common/procs.rkt +++ b/collects/mred/private/wx/common/procs.rkt @@ -5,10 +5,10 @@ label->plain-label) (define/top (label->plain-label [string? s]) - (regexp-replace* #rx"&." + (regexp-replace* #rx"&(.)" (regexp-replace - #rx"[(]&.[)] *" + #rx"[(]&(.)[)] *" (regexp-replace #rx"\t.*$" s "") - "") - "")) + "\\1") + "\\1")) diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index 65c4b0d521..6eeb09ee35 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -8,6 +8,7 @@ "window.rkt" "const.rkt" "pixbuf.rkt" + "message.rkt" "../common/event.rkt") (unsafe!) @@ -16,7 +17,7 @@ ;; ---------------------------------------- -(define-gtk gtk_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_button_new (_fun -> _GtkWidget)) (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) @@ -28,7 +29,7 @@ (defclass button-core% item% (init parent cb label x y w h style font - [gtk_new_with_label gtk_button_new_with_label] + [gtk_new_with_mnemonic gtk_button_new_with_mnemonic] [gtk_new gtk_button_new]) (init-field [event-type 'button]) (inherit get-gtk set-auto-size is-window-enabled? @@ -37,7 +38,7 @@ (super-new [parent parent] [gtk (cond [(or (string? label) (not label)) - (gtk_new_with_label (or label ""))] + (gtk_new_with_mnemonic (or (mnemonic-string label) ""))] [(send label ok?) (let ([gtk (gtk_new)] [image-gtk (gtk_image_new_from_pixbuf @@ -46,7 +47,7 @@ (gtk_widget_show image-gtk) gtk)] [else - (gtk_new_with_label "")])] + (gtk_new_with_mnemonic "")])] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt index 495e61ee97..d9ff0f5646 100644 --- a/collects/mred/private/wx/gtk/check-box.rkt +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -12,13 +12,13 @@ ;; ---------------------------------------- -(define-gtk gtk_check_button_new_with_label (_fun _string -> _GtkWidget)) +(define-gtk gtk_check_button_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_check_button_new (_fun -> _GtkWidget)) (define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) (define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) (defclass check-box% button-core% - (super-new [gtk_new_with_label gtk_check_button_new_with_label] + (super-new [gtk_new_with_mnemonic gtk_check_button_new_with_mnemonic] [gtk_new gtk_check_button_new] [event-type 'check-box]) (inherit get-gtk) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index cefaccb742..6d6c3563c4 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe ffi/unsafe/define scheme/class + (only-in racket/list take drop) "../../syntax.rkt" "../../lock.rkt" "item.rkt" @@ -28,6 +29,7 @@ (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) (define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore)) +(define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void)) (define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) (define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) (define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) @@ -36,11 +38,19 @@ (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) +(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) +(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) (define _GList (_cpointer 'List)) (define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) (define-glib g_list_free (_fun _GList -> _void)) (define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) +(define-gtk gtk_tree_selection_path_is_selected (_fun _GtkWidget _pointer -> _gboolean)) +(define-gtk gtk_tree_selection_unselect_all (_fun _GtkWidget -> _void)) +(define-gtk gtk_tree_selection_select_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_selection_unselect_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_path_new_from_indices (_fun _int _int -> _pointer)) (define-gtk gtk_tree_path_free (_fun _pointer -> _void)) (define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) @@ -65,10 +75,12 @@ (define data (map (lambda (c) (box #f)) choices)) (define store (gtk_list_store_new 1 G_TYPE_STRING)) - (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (for ([s (in-list choices)]) - (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1))) + (define (reset-content) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (for ([s (in-list items)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)))) + (reset-content) (define column (let ([renderer (gtk_cell_renderer_text_new)]) @@ -111,14 +123,37 @@ (queue-window-event this (lambda () - (callback this (new control-event% - [event-type 'list-box] - [time-stamp (current-milliseconds)]))))) + (unless (null? items) + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)])))))) + + (define/private (get-iter i) + (let ([iter (make-GtkTreeIter 0 #f #f #f)] + [p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_model_get_iter store iter p) + (gtk_tree_path_free p) + iter)) (def/public-unimplemented get-label-font) - (def/public-unimplemented set-string) - (def/public-unimplemented set-first-visible-item) - (def/public-unimplemented set) + + (define/public (set-string i s) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) + (gtk_list_store_set store (get-iter i) 0 s -1)) + + (define/public (set-first-visible-item i) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) + (gtk_tree_path_free p))) + + (define/public (set choices) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content)) (define/public (get-selections) (as-entry @@ -163,11 +198,35 @@ (define/public (set-data i v) (set-box! (list-ref data i) v)) (define/public (get-data i) (unbox (list-ref data i))) - (def/public-unimplemented selected?) - (def/public-unimplemented set-selection) - (def/public-unimplemented select) - (def/public-unimplemented delete) - (def/public-unimplemented clear) + (define/public (selected? i) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (begin0 + (gtk_tree_selection_path_is_selected selection p) + (gtk_tree_path_free p)))) + + (define/public (select i [on? #t] [extend? #t]) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p))) + + (define/public (set-selection i) + (select i #t #f)) + + (define/public (delete i) + (set! items (append (take items i) (drop items (add1 i)))) + (set! data (append (take data i) (drop data (add1 i)))) + (gtk_list_store_remove store (get-iter i)) + (void)) + + (define/public (clear) + (set! items null) + (set! data null) + (gtk_list_store_clear store)) (public [append* append]) (define (append* s [v #f]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 011a59b0b4..0ce0b70db7 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -8,12 +8,35 @@ "pixbuf.rkt") (unsafe!) -(provide message%) +(provide message% + + gtk_label_new_with_mnemonic + gtk_label_set_text_with_mnemonic + mnemonic-string) ;; ---------------------------------------- (define-gtk gtk_label_new (_fun _string -> _GtkWidget)) (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) + +(define (mnemonic-string s) + (if (regexp-match? #rx"&" s) + (regexp-replace* + #rx"_&" + (regexp-replace* + #rx"&(.)" + (regexp-replace* #rx"_" s "__") + "_\\1") + "\\&") + (regexp-replace* #rx"_" s "__"))) + +(define (gtk_label_new_with_mnemonic s) + (let ([l (gtk_label_new s)]) + (when (regexp-match? #rx"&" s) + (let ([s (mnemonic-string s)]) + (gtk_label_set_text_with_mnemonic l s))) + l)) (defclass message% item% (init parent label @@ -24,7 +47,7 @@ (super-new [parent parent] [gtk (if (or (string? label) (not label)) - (gtk_label_new (or label "")) + (gtk_label_new_with_mnemonic (or label "")) (if (symbol? label) (gtk_label_new (format "<~a>" label)) (gtk_image_new_from_pixbuf @@ -34,6 +57,6 @@ (set-auto-size) (define/override (set-label s) - (gtk_label_set_text (get-gtk) s)) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index e55ff7cb3a..1ce9cc4163 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -7,7 +7,9 @@ "utils.rkt" "panel.rkt" "types.rkt" - "widget.rkt") + "widget.rkt" + "message.rkt" + "../common/event.rkt") (unsafe!) (provide tab-panel%) @@ -15,10 +17,10 @@ (define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) -(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) -(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) @@ -59,16 +61,19 @@ (define pages (for/list ([lbl labels]) (let ([bin-gtk (gtk_hbox_new #f 0)] - [label-gtk (gtk_label_new lbl)]) + [label-gtk (gtk_label_new_with_mnemonic lbl)]) (gtk_notebook_append_page gtk bin-gtk label-gtk) (gtk_widget_show bin-gtk) (make-page bin-gtk label-gtk)))) + (define/private (install-empty-page) + (gtk_notebook_append_page gtk empty-bin-gtk #f) + (gtk_widget_show empty-bin-gtk)) + (if (null? pages) (begin (select-bin empty-bin-gtk) - (gtk_notebook_append_page gtk empty-bin-gtk #f) - (gtk_widget_show empty-bin-gtk)) + (install-empty-page)) (begin (select-bin (page-bin-gtk (car pages))))) (gtk_widget_show client-gtk) @@ -81,21 +86,71 @@ (set-auto-size) + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/private (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) + + (define/public (swap-in bin-gtk) + (gtk_widget_ref client-gtk) + (gtk_container_remove current-bin-gtk client-gtk) + (select-bin bin-gtk) + (gtk_widget_unref client-gtk)) + (define/public (page-changed i) - (let ([bin-gtk (page-bin-gtk (list-ref pages i))]) - (gtk_widget_ref client-gtk) - (gtk_container_remove current-bin-gtk client-gtk) - (select-bin bin-gtk) - (gtk_widget_unref client-gtk))) + (unless (null? pages) + (swap-in (page-bin-gtk (list-ref pages i))) + (queue-window-event this (lambda () (do-callback))))) (connect-changed gtk) (define/override (get-client-gtk) client-gtk) + (public [append* append]) + (define (append* lbl) + (let ([page + (let ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)]) + (gtk_notebook_append_page gtk bin-gtk label-gtk) + (gtk_widget_show bin-gtk) + (make-page bin-gtk label-gtk))]) + (set! pages (append pages (list page))) + (when (null? (cdr pages)) + (swap-in (page-bin-gtk (car pages))) + (g_object_ref empty-bin-gtk) + (gtk_notebook_remove_page gtk 0)))) + + (define/public (delete i) + (let ([page (list-ref pages i)]) + (when (ptr-equal? current-bin-gtk (page-bin-gtk page)) + (let ([cnt (length pages)]) + (if (= i (sub1 cnt)) + (if (null? (cdr pages)) + (begin + (install-empty-page) + (set! pages null) + (gtk_notebook_set_current_page gtk 1) + (swap-in empty-bin-gtk)) + (gtk_notebook_set_current_page gtk (sub1 i))) + (gtk_notebook_set_current_page gtk (add1 i))))) + (gtk_notebook_remove_page gtk i) + (set! pages (remq page pages)))) + + (define/public (set choices) + (for ([page (in-list pages)]) + (delete 0)) + (for ([lbl (in-list choices)]) + (append* lbl))) + (define/public (set-label i str) - (gtk_label_set_text (page-label-gtk (list-ref pages i)) str)) + (gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i)) + (mnemonic-string str))) (define/public (set-selection i) (gtk_notebook_set_current_page gtk i)) + (define/public (get-selection) + (gtk_notebook_get_current_page gtk)) (define/override (set-child-size child-gtk x y w h) (gtk_fixed_move client-gtk child-gtk x y) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 54f5b469e2..536ecae71f 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -177,7 +177,7 @@ (get-data i) (selected? i) (delete i) - (clear i) + (clear) (set choices) (reset)) (define/public select