suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mostly tab-panel and mnemonic repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-06-13 12:32:05 -06:00
parent edd12a64b8
commit 3cb7594793
12 changed files with 238 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/mrpanel.rkt
View File

@ -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))]

2
collects/mred/private/wx/cocoa/button.rkt
View File

@ -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 "")

7
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -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)

6
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -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
"<bad>")))
(tellv button setTitleWithMnemonic: #:type _NSString (if (string? label)
label
"<bad>")))
(tellv button setButtonType: #:type _int NSRadioButton)))
(tellv cocoa sizeToFit)
(tellv cocoa setTarget: cocoa)

54
collects/mred/private/wx/cocoa/tab-panel.rkt
View File

@ -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]

8
collects/mred/private/wx/common/procs.rkt
View File

@ -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"))

9
collects/mred/private/wx/gtk/button.rkt
View File

@ -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 "<bad>")])]
(gtk_new_with_mnemonic "<bad>")])]
[no-show? (memq 'deleted style)])
(define gtk (get-gtk))

4
collects/mred/private/wx/gtk/check-box.rkt
View File

@ -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)

89
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -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])

29
collects/mred/private/wx/gtk/message.rkt
View File

@ -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))

79
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -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)

2
collects/mred/private/wxlitem.rkt
View File

@ -177,7 +177,7 @@
(get-data i)
(selected? i)
(delete i)
(clear i)
(clear)
(set choices)
(reset))
(define/public select