diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index ffee140991..aeb7b56f3f 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -32,6 +32,7 @@ clipboard<%> color% color-database<%> combo-field% +column-control-event% control-event% control<%> current-eventspace diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 889008b6d4..47e643be51 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -107,6 +107,7 @@ clipboard<%> clipboard-client% control-event% + column-control-event% current-eventspace cursor% get-display-depth diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index e8b152f1e8..fa5bc953cf 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -1,8 +1,8 @@ -(module mritem mzscheme +(module mritem racket/base (require mzlib/class mzlib/class100 mzlib/list - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "const.ss" "kw.ss" @@ -16,8 +16,8 @@ "mrcontainer.ss") (provide control<%> - (protect control%-keywords - basic-control%) + (protect-out control%-keywords + basic-control%) message% button% check-box% @@ -29,13 +29,13 @@ choice% list-box% - (protect wrap-callback - check-list-control-args - check-list-control-selection - - ;; Local methods: - hidden-child? - label-checker)) + (protect-out wrap-callback + check-list-control-args + check-list-control-selection + + ;; Local methods: + hidden-child? + label-checker)) (define control<%> (interface (subwindow<%>) @@ -555,26 +555,138 @@ (define list-box% (class100*/kw basic-list-control% () [(label choices parent [callback (lambda (b e) (void))] [style '(single)] [selection #f] [font no-val] [label-font no-val]) - control%-nofont-keywords] + control%-nofont-keywords + [columns (list "Column")] + [column-order #f]] (sequence (let ([cwho '(constructor list-box)]) (check-list-control-args cwho label choices parent callback) - (check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style) + (check-style cwho '(single multiple extended) + '(vertical-label horizontal-label deleted variable-columns + column-headers clickable-headers reorderable-headers) + style) (check-non-negative-integer/false cwho selection) (check-font cwho font) - (check-font cwho label-font))) + (check-font cwho label-font) + (unless (and (list? columns) + (not (null? columns)) + (andmap label-string? columns)) + (raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters)" columns)) + (when column-order + (check-column-order cwho column-order (length columns))))) + (private + [check-column-order + (lambda (cwho column-order count) + (unless (and (list? column-order) + (andmap exact-integer? column-order) + (equal? (sort column-order <) + (for/list ([i (in-range (length column-order))]) i))) + (raise-type-error (who->name cwho) + "#f or list of distinct exact integers from 0 to one less than the list length" + column-order)) + (unless (= (length column-order) count) + (raise-mismatch-error (who->name cwho) + (format "column count ~a does not match length of column-order list: " + count) + column-order)))] + [check-column-number + (lambda (who i) + (unless (exact-nonnegative-integer? i) + (raise-type-error (who->name who) "exact nonnegative integer" i)) + (unless (i . < . num-columns) + (raise-mismatch-error (who->name who) + (format + "index is too large for ~a-column list box: " + num-columns) + i)))]) + (private-field + [column-labels (map string->immutable-string columns)] + [num-columns (length columns)] + [variable-columns? (memq 'variable-columns style)]) (rename [super-append append]) (override - [append (entry-point - (case-lambda - [(i) - (super-append i)] - [(i d) - (check-label-string '(method list-control<%> append) i) - (send this -append-list-string i) - (send wx append i d)]))]) + [(-append append) + (entry-point + (case-lambda + [(i) + (super-append i)] + [(i d) + (check-label-string '(method list-control<%> append) i) + (send this -append-list-string i) + (send wx append i d)]))]) (public - [delete (entry-point (lambda (n) + [get-column-labels (lambda () column-labels)] + [get-column-order (lambda () (send wx get-column-order))] + [set-column-order (lambda (co) + (check-column-order '(method list-box% set-column-order) co num-columns) + (send wx set-column-order co))] + [set-column-label (lambda (i str) + (let ([who '(method list-box% set-column-label)]) + (check-column-number who i) + (check-label-string who str)) + (let ([str (string->immutable-string str)]) + (set! column-labels (let loop ([i i] [l column-labels]) + (cond + [(zero? i) (cons str (cdr l))] + [else (cons (car l) (loop (sub1 i) (cdr l)))]))) + (send wx set-column-label i str)))] + [set-column-size (lambda (i w min-size max-size) + (let ([who '(method list-box% set-column-size)]) + (check-column-number who i) + (check-dimension who w) + (check-dimension who min-size) + (check-dimension who max-size) + (unless (<= min-size w) + (raise-mismatch-error (who->name who) + (format + "size ~a is less than mininum size: " + w) + min-size)) + (unless (>= max-size w) + (raise-mismatch-error (who->name who) + (format + "size ~a is less than maximum size: " + w) + max-size))) + (send wx set-column-size i w min-size max-size))] + [get-column-size (lambda (i) + (check-column-number '(method list-box% get-column-size) i) + (send wx get-column-size i))] + [delete-column (lambda (i) + (let ([who '(method list-box% delete-column)]) + (check-column-number who i) + (unless variable-columns? + (raise-mismatch-error + (who->name who) + "list box without 'variable-columns style cannot delete column: " + i)) + (unless (num-columns . > . 1) + (raise-mismatch-error (who->name who) + "cannot delete only column: " + i))) + (as-entry + (lambda () + (set! num-columns (sub1 num-columns)) + (set! column-labels (let loop ([i i] [l column-labels]) + (cond + [(zero? i) (cdr l)] + [else (cons (car l) (loop (sub1 i) (cdr l)))]))) + (send wx delete-column i))))] + [append-column (lambda (label) + (let ([who '(method list-box% append-column)]) + (check-label-string who label) + (unless variable-columns? + (raise-mismatch-error + (who->name who) + "list box without 'variable-columns style cannot add column: " + label))) + (as-entry + (lambda () + (set! num-columns (add1 num-columns)) + (set! column-labels (append column-labels (list label))) + (send wx append-column label))))] + + [delete (entry-point (lambda (n) (check-item 'delete n) (send this -delete-list-item n) (send wx delete n)))] @@ -583,19 +695,43 @@ [get-selections (entry-point (lambda () (send wx get-selections)))] [number-of-visible-items (entry-point (lambda () (send wx number-of-visible-items)))] [is-selected? (entry-point (lambda (n) (check-item 'is-selected? n) (send wx selected? n)))] - [set (entry-point (lambda (l) - (unless (and (list? l) (andmap label-string? l)) - (raise-type-error (who->name '(method list-box% set)) - "list of strings (up to 200 characters)" l)) + [set (entry-point (lambda (l . more) + (let ([cwho '(method list-box% set)]) + (unless (= num-columns (+ 1 (length more))) + (raise-mismatch-error (who->name cwho) + (format + "column count ~a doesn't match number of arguments: " + num-columns) + (add1 (length more)))) + (for ([l (in-list (cons l more))]) + (unless (and (list? l) (andmap label-string? l)) + (raise-type-error (who->name cwho) + "list of strings (up to 200 characters)" l))) + (for ([more-l (in-list more)]) + (unless (= (length more-l) (length l)) + (raise-mismatch-error + (who->name cwho) + (format "first list length ~a does not match length of later argument: " + (length l)) + more-l)))) (send this -set-list-strings l) - (send wx set l)))] + (send wx set l . more)))] [set-string (entry-point - (lambda (n d) - (check-non-negative-integer '(method list-box% set-string) n) ; int error before string - (check-label-string '(method list-box% set-string) d) ; string error before range mismatch + (lambda (n d [col 0]) + (let ([cwho '(method list-box% set-string)]) + (check-non-negative-integer cwho n) ; int error before string + (check-label-string cwho d) ; string error before range mismatch + (unless (exact-nonnegative-integer? col) + (raise-type-error (who->name cwho) "exact nonnegative integer" col)) + (unless (< -1 col num-columns) + (raise-mismatch-error (who->name cwho) + (format + "column number is not in the list box's allowed range [0, ~a]: " + (sub1 num-columns)) + col))) (check-item 'set-string n) (send this -set-list-string n d) - (send wx set-string n d)))] + (send wx set-string n d col)))] [set-data (entry-point (lambda (n d) (check-item 'set-data n) (send wx set-data n d)))] [get-first-visible-item (entry-point (lambda () (send wx get-first-item)))] [set-first-visible-item (entry-point (lambda (n) @@ -631,7 +767,9 @@ (mred->wx-container parent) (wrap-callback callback) label kind -1 -1 -1 -1 choices style - (no-val->#f font) (no-val->#f label-font)))) + (no-val->#f font) (no-val->#f label-font) + column-labels + column-order))) wx) (lambda () (let ([cwho '(constructor list-box)]) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 0c8828ba0b..2083d71a02 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -28,7 +28,7 @@ (let ([wx (->wx wxb)]) (tell (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-row row) "???"))] + (if wx (send wx get-cell column row) "???"))] [font (and wx (send wx get-cell-font))]) (when font (tellv c setFont: font)) @@ -37,7 +37,12 @@ [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] [-a _void (tableViewSelectionDidChange: [_id aNotification]) - (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))]) + (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))] + [-a _void (tableView: [_id view] didClickTableColumn: [_id col]) + (queue-window*-event wxb (lambda (wx) (send wx clicked-column col)))] + [-a _void (tableViewColumnDidMove: [_id view]) + (let ([wx (->wx wxb)]) + (when wx (send wx reset-column-order)))]) (define-objc-class MyDataSource NSObject #:protocols (NSTableViewDataSource) @@ -50,7 +55,7 @@ row: [_NSInteger rowIndex]) (let ([wx (->wx wxb)]) (if wx - (send wx get-row rowIndex) + (send wx get-cell aTableColumn rowIndex) "???"))]) (define (remove-nth data i) @@ -62,7 +67,8 @@ (init parent cb label kind x y w h choices style - font label-font) + font label-font + columns column-order) (inherit set-size init-font register-as-child) @@ -70,30 +76,74 @@ (tell (tell MyDataSource alloc) init))) (set-ivar! source wxb (->wxb this)) - (define items choices) + (define itemss (cons choices + (for/list ([i (in-list (cdr columns))]) + (for/list ([i choices]) + "")))) + (define num-columns (length columns)) (define data (map (lambda (x) (box #f)) choices)) (define count (length choices)) (define cocoa (as-objc-allocation (tell (tell NSScrollView alloc) init))) - (define content-cocoa (let ([content-cocoa - (as-objc-allocation - (tell (tell MyTableView alloc) init))]) - (tellv content-cocoa setDelegate: content-cocoa) - (tellv content-cocoa setDataSource: source) - (tellv content-cocoa addTableColumn: - (as-objc-allocation - (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))) - (init-font content-cocoa font) - content-cocoa)) + (define-values (content-cocoa column-cocoas) + (let ([content-cocoa + (as-objc-allocation + (tell (tell MyTableView alloc) init))]) + (tellv content-cocoa setDelegate: content-cocoa) + (tellv content-cocoa setDataSource: source) + (define cols + (for/list ([title (in-list columns)]) + (let ([col (as-objc-allocation + (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))]) + (tellv content-cocoa addTableColumn: col) + (tellv (tell col headerCell) setStringValue: #:type _NSString title) + col))) + (init-font content-cocoa font) + (values content-cocoa cols))) (set-ivar! content-cocoa wxb (->wxb this)) (tellv cocoa setDocumentView: content-cocoa) (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) - (tellv content-cocoa setHeaderView: #f) + (unless (memq 'column-headers style) + (tellv content-cocoa setHeaderView: #f)) (define allow-multi? (not (eq? kind 'single))) (when allow-multi? (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t)) + (unless (memq 'reorderable-headers style) + (tellv content-cocoa setAllowsColumnReordering: #:type _BOOL #f)) + + (when column-order + (set-column-order column-order)) + (define/public (set-column-order column-order) + (atomically + (for ([c (in-list column-cocoas)]) + (tellv c retain) + (tellv content-cocoa removeTableColumn: c)) + (for ([pos (in-list column-order)]) + (let ([c (list-ref column-cocoas pos)]) + (tellv content-cocoa addTableColumn: c) + (tellv c release))) + (reset-column-order))) + + (define/public (set-column-label i s) + (let ([col (list-ref column-cocoas i)]) + (tellv (tell col headerCell) setStringValue: #:type _NSString s) + (reset))) + + (define/public (set-column-size i w min-w max-w) + (let ([col (list-ref column-cocoas i)]) + (tellv col setMinWidth: #:type _CGFloat min-w) + (tellv col setMaxWidth: #:type _CGFloat max-w) + (tellv col setWidth: #:type _CGFloat w))) + + (define/public (get-column-size i) + (let ([col (list-ref column-cocoas i)] + [int (lambda (v) (inexact->exact (round v)))]) + (values + (int (tell #:type _CGFloat col width)) + (int (tell #:type _CGFloat col minWidth)) + (int (tell #:type _CGFloat col maxWidth))))) (define/override (get-cocoa-content) content-cocoa) (define/override (get-cocoa-control) content-cocoa) @@ -145,19 +195,87 @@ ;; FIXME: visble doesn't mean at top: (tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) - (define/public (set-string i s) - (set! items - (append (take items i) - (list s) - (drop items (add1 i)))) + (define/private (replace items i s) + (append (take items i) + (list s) + (drop items (add1 i)))) + + (define/public (set-string i s [col 0]) + (let ([new-itemss (replace + itemss + col + (replace (list-ref itemss col) + i + s))]) + (set! itemss new-itemss)) (reset)) (define/public (number) ;; Can be called by event-handling thread count) - (define/public (get-row n) + (define/public (get-cell col n) ;; Can be called by event-handling thread - (list-ref items n)) + (let ([col (if (number? col) + (order->number col) + (col->number col))]) + (if (col . > . num-columns) ; can happen as column is deleted + "" + (list-ref (list-ref itemss col) n)))) + + (define/private (col->number col) + (let loop ([l column-cocoas] [pos 0]) + (cond + [(null? l) #f] + [(ptr-equal? (car l) col) pos] + [else (loop (cdr l) (add1 pos))]))) + + ;; When columns are rearranged, we have to be able to map + ;; from current column numbers to original column numbers + (define order-vector #f) + (define/private (order->number col) + (prep-order-vector) + (vector-ref order-vector col)) + (define/private (prep-order-vector) + (unless order-vector + (let ([vec (make-vector (length column-cocoas))]) + (let ([array (tell content-cocoa tableColumns)]) + (for/list ([i (in-range (tell #:type _NSUInteger array count))]) + (let ([col (tell array objectAtIndex: #:type _NSUInteger i)]) + (vector-set! vec i (col->number col))))) + (set! order-vector vec)))) + (define/public (reset-column-order) + (set! order-vector #f)) + + (define/public (get-column-order) + (prep-order-vector) + (vector->list order-vector)) + + (define/public (append-column title) + (atomically + (let ([col (as-objc-allocation + (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))]) + (tellv content-cocoa addTableColumn: col) + (tellv (tell col headerCell) setStringValue: #:type _NSString title) + (set! column-cocoas (append column-cocoas (list col))) + (set! itemss (append itemss + (list (for/list ([i (in-list (car itemss))]) + "")))) + (set! num-columns (add1 num-columns)) + (reset-column-order))) + (reset)) + + (define/public (delete-column i) + (atomically + (let ([c (list-ref column-cocoas i)]) + (define (drop-nth l i) + (cond + [(zero? i) (cdr l)] + [else (cons (car l) (drop-nth (cdr l) (sub1 i)))])) + (set! num-columns (sub1 num-columns)) + (tellv content-cocoa removeTableColumn: c) + (set! column-cocoas (drop-nth column-cocoas i)) + (set! itemss (drop-nth itemss i)))) + (reset)) (define callback cb) (define/public (clicked event-type) @@ -166,6 +284,15 @@ [event-type event-type] [time-stamp (current-milliseconds)])))) + (define can-click-column? (memq 'clickable-headers style)) + (define/public (clicked-column col) + (when can-click-column? + (let ([pos (col->number col)]) + (callback this (new column-control-event% + [event-type 'list-box-column] + [time-stamp (current-milliseconds)] + [column pos]))))) + (define/public (set-data i v) (set-box! (list-ref data i) v)) (define/public (get-data i) (unbox (list-ref data i))) @@ -185,26 +312,34 @@ (select i #t #f)) (define/public (delete i) - (set! count (sub1 count)) - (set! items (remove-nth items i)) - (set! data (remove-nth data i)) + (atomically + (set! count (sub1 count)) + (set! itemss (for/list ([items (in-list itemss)]) + (remove-nth items i))) + (set! data (remove-nth data i))) (reset)) (define/public (clear) - (set! count 0) - (set! items null) - (set! data null) + (atomically + (set! count 0) + (set! itemss (for/list ([items (in-list itemss)]) + null)) + (set! data null)) (reset)) - (define/public (set choices) - (set! items choices) - (set! data (map (lambda (x) (box #f)) choices)) - (set! count (length choices)) + (define/public (set choices . more-choices) + (atomically + (set! itemss (cons choices more-choices)) + (set! data (map (lambda (x) (box #f)) choices)) + (set! count (length choices))) (reset)) (public [append* append]) (define (append* s [v #f]) - (set! count (add1 count)) - (set! items (append items (list s))) - (set! data (append data (list (box v)))) + (atomically + (set! count (add1 count)) + (set! itemss (cons (append (car itemss) (list s)) + (for/list ([items (in-list (cdr itemss))]) + (append items (list ""))))) + (set! data (append data (list (box v))))) (reset)) (define/public (reset) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index 88f1fc5fec..5cdd153e13 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -6,6 +6,7 @@ mouse-event% key-event% control-event% + column-control-event% scroll-event% popup-event%) @@ -90,13 +91,24 @@ (defclass control-event% event% (init-properties [[(symbol-in button check-box choice - list-box list-box-dclick text-field + list-box list-box-dclick list-box-column text-field text-field-enter slider radio-box menu-popdown menu-popdown-none tab-panel) event-type]]) (init [time-stamp 0]) (super-new [time-stamp time-stamp])) +(defclass column-control-event% control-event% + (init-properties [[exact-nonnegative-integer? column]]) + (init event-type + [time-stamp 0]) + (unless (eq? event-type 'list-box-column) + (raise-type-error (init-name 'column-control-event%) + "'list-box-column" + event-type)) + (super-new [event-type event-type] + [time-stamp time-stamp])) + (defclass popup-event% control-event% (properties [[any? menu-id] 0]) (super-new)) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 886f4c9c52..3a1fd1c43f 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -29,23 +29,42 @@ (define GTK_SELECTION_SINGLE 1) (define GTK_SELECTION_MULTIPLE 3) +(define GTK_TREE_VIEW_COLUMN_AUTOSIZE 1) +(define GTK_TREE_VIEW_COLUMN_FIXED 2) + (define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) -(define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore)) +(define-gtk gtk_list_store_newv (_fun _int (_list i _long) -> _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)) +(define-gtk gtk_tree_view_set_model (_fun _GtkWidget _GtkListStore -> _void)) (define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer)) (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) +(define-gtk gtk_tree_view_column_set_attributes (_fun _GtkTreeViewColumn _GtkCellRenderer _string _int _pointer -> _void)) +(define-gtk gtk_tree_view_column_set_resizable (_fun _GtkTreeViewColumn _gboolean -> _void)) +(define-gtk gtk_tree_view_column_set_clickable (_fun _GtkTreeViewColumn _gboolean -> _void)) +(define-gtk gtk_tree_view_column_set_reorderable (_fun _GtkTreeViewColumn _gboolean -> _void)) (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) +(define-gtk gtk_tree_view_remove_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) (define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void)) (define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) (define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) (define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) +(define-gtk gtk_tree_view_get_column (_fun _GtkWidget _int -> _GtkTreeViewColumn)) +(define-gtk gtk_tree_view_move_column_after (_fun _GtkWidget _GtkTreeViewColumn (_or-null _GtkTreeViewColumn) -> _void)) +(define-gtk gtk_tree_view_column_set_title (_fun _GtkTreeViewColumn _string -> _void)) +(define-gtk gtk_tree_view_column_set_sizing (_fun _GtkTreeViewColumn _int -> _void)) +(define-gtk gtk_tree_view_column_get_width (_fun _GtkTreeViewColumn -> _int)) +(define-gtk gtk_tree_view_column_get_min_width (_fun _GtkTreeViewColumn -> _int)) +(define-gtk gtk_tree_view_column_get_max_width (_fun _GtkTreeViewColumn -> _int)) +(define-gtk gtk_tree_view_column_set_fixed_width (_fun _GtkTreeViewColumn _int -> _int)) +(define-gtk gtk_tree_view_column_set_min_width (_fun _GtkTreeViewColumn _int -> _int)) +(define-gtk gtk_tree_view_column_set_max_width (_fun _GtkTreeViewColumn _int -> _int)) (define _GList (_cpointer 'List)) (define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) @@ -70,6 +89,13 @@ (when wx (send wx queue-changed))))) +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx column-clicked gtk))))) + (define-signal-handler connect-activated "row-activated" (_fun _GtkWidget _pointer _pointer -> _void) (lambda (gtk path column) @@ -81,18 +107,33 @@ (init parent cb label kind x y w h choices style - font label-font) + font label-font + columns + column-order) (inherit get-gtk set-auto-size is-window-enabled?) - (define items choices) + (define empty-columns (for/list ([l (in-list (cdr columns))]) + "")) + (define itemss (for/list ([i (in-list choices)]) + (cons i empty-columns))) + (define data (map (lambda (c) (box #f)) choices)) - (define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING))) + + (define (make-store count) + (as-gobject-allocation + (gtk_list_store_newv count + (for/list ([i (in-range count)]) + G_TYPE_STRING)))) + (define store (make-store (length columns))) + (define (reset-content) (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (for ([s (in-list items)]) + (for ([items (in-list itemss)]) (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1))) + (for ([item (in-list items)] + [col (in-naturals 0)]) + (gtk_list_store_set store iter col item -1)))) (maybe-init-select)) (define/private (maybe-init-select) @@ -103,20 +144,51 @@ (define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f))) (gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS) - (define client-gtk + (define headers? (memq 'column-headers style)) + (define click-headers? (and headers? + (memq 'clickable-headers style))) + (define reorder-headers? (and headers? + (memq 'reorderable-headers style))) + + (define renderer (gtk_cell_renderer_text_new)) + + (define/private (make-column label col) + (let* ([column + (gtk_tree_view_column_new_with_attributes + label + renderer + "text" + col + #f)]) + (when headers? + (gtk_tree_view_column_set_resizable column #t) + (when click-headers? + (gtk_tree_view_column_set_clickable column #t)) + (when reorder-headers? + (gtk_tree_view_column_set_reorderable column #t))) + column)) + + (define-values (client-gtk column-gtks) (atomically (let* ([client-gtk (gtk_tree_view_new_with_model store)] - [column (let ([renderer (gtk_cell_renderer_text_new)]) - (gtk_tree_view_column_new_with_attributes - "column" - renderer - "text" - 0 - #f))]) + [columns (for/list ([label (in-list columns)] + [col (in-naturals)]) + (make-column label col))]) (gobject-unref store) - (gtk_tree_view_set_headers_visible client-gtk #f) - (gtk_tree_view_append_column client-gtk column) - client-gtk))) + (unless headers? + (gtk_tree_view_set_headers_visible client-gtk #f)) + (for ([column (in-list columns)]) + (gtk_tree_view_append_column client-gtk column)) + (values client-gtk columns)))) + + (when column-order + (set-column-order column-order)) + (define/public (set-column-order column-order) + (let loop ([prev #f] [l column-order]) + (unless (null? l) + (let ([column-gtk (list-ref column-gtks (car l))]) + (gtk_tree_view_move_column_after client-gtk column-gtk prev) + (loop column-gtk (cdr l)))))) (gtk_container_add gtk client-gtk) (gtk_widget_show client-gtk) @@ -131,7 +203,10 @@ (super-new [parent parent] [gtk gtk] - [extra-gtks (list client-gtk selection)] + [extra-gtks (list* client-gtk selection + (if (memq 'clickable-headers style) + column-gtks + null))] [callback cb] [font font] [no-show? (memq 'deleted style)]) @@ -140,6 +215,14 @@ (connect-changed selection) (connect-activated client-gtk) + (for ([column (in-list column-gtks)]) + (column-finish column)) + + (define/private (column-finish column) + (connect-clicked column) + (let ([w (gtk_tree_view_column_get_width column)]) + (gtk_tree_view_column_set_sizing column GTK_TREE_VIEW_COLUMN_FIXED) + (gtk_tree_view_column_set_fixed_width column (max 50 w)))) (define/override (get-client-gtk) client-gtk) @@ -151,7 +234,7 @@ (queue-window-event this (lambda () - (unless (null? items) + (unless (null? itemss) (callback this (new control-event% [event-type type] [time-stamp (current-milliseconds)]))))))) @@ -162,6 +245,29 @@ (define/public (queue-activated) (do-queue-changed 'list-box-dclick)) + (define/private (column->pos col) + (let loop ([l column-gtks] + [pos 0]) + (cond + [(null? l) #f] + [(ptr-equal? (car l) col) pos] + [else (loop (cdr l) (add1 pos))]))) + + (define/public (column-clicked col) + (let ([pos (column->pos col)]) + (when pos + (queue-window-event + this + (lambda () + (callback this (new column-control-event% + [event-type 'list-box-column] + [column pos] + [time-stamp (current-milliseconds)]))))))) + + (define/public (get-column-order) + (for/list ([i (in-range (length column-gtks))]) + (column->pos (gtk_tree_view_get_column client-gtk i)))) + (define/private (get-iter i) (atomically (let ([iter (make-GtkTreeIter 0 #f #f #f)] @@ -172,12 +278,38 @@ (def/public-unimplemented get-label-font) - (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/private (replace-nth items i s) + (append (take items i) + (list s) + (drop items (add1 i)))) + + (define/public (set-string i s [col 0]) + (set! itemss + (replace-nth itemss + i + (replace-nth (list-ref itemss i) + col + s))) + (gtk_list_store_set store (get-iter i) col s -1)) + + (define/public (set-column-label i s) + (gtk_tree_view_column_set_title (list-ref column-gtks i) s)) + + (define/public (set-column-size i w mn mx) + (let ([col (list-ref column-gtks i)]) + (gtk_tree_view_column_set_min_width col mn) + (gtk_tree_view_column_set_max_width col mx) + (gtk_tree_view_column_set_fixed_width col w))) + + (define/public (get-column-size i) + (let ([col (list-ref column-gtks i)]) + (values + (gtk_tree_view_column_get_width col) + (max (gtk_tree_view_column_get_min_width col) 0) + (let ([v (gtk_tree_view_column_get_max_width col)]) + (if (negative? v) + 10000 + v))))) (define/public (set-first-visible-item i) (atomically @@ -185,11 +317,15 @@ (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) (gtk_tree_path_free p)))) - (define/public (set choices) + (define/public (set choices . more-choices) (atomically (set! ignore-click? #t) (clear) - (set! items choices) + (set! itemss (apply map + (lambda (i . rest) + (cons i rest)) + choices + more-choices)) (set! data (map (lambda (x) (box #f)) choices)) (reset-content) (set! ignore-click? #f))) @@ -230,7 +366,7 @@ (let-values ([(start end) (get-visible-range)]) (add1 (- end start)))) - (define/public (number) (length items)) + (define/public (number) (length itemss)) (define/public (set-data i v) (set-box! (list-ref data i) v)) (define/public (get-data i) (unbox (list-ref data i))) @@ -259,13 +395,13 @@ (select i #t #f)) (define/public (delete i) - (set! items (append (take items i) (drop items (add1 i)))) + (set! itemss (append (take itemss i) (drop itemss (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! itemss null) (set! data null) (gtk_list_store_clear store)) @@ -273,7 +409,8 @@ (define (append* s [v #f]) (atomically (set! ignore-click? #t) - (set! items (append items (list s))) + (set! itemss (append itemss + (list (cons s empty-columns)))) (set! data (append data (list (box v)))) (let ([iter (make-GtkTreeIter 0 #f #f #f)]) (gtk_list_store_append store iter #f) @@ -281,4 +418,49 @@ (maybe-init-select) (set! ignore-click? #f))) + (define/public (append-column label) + (let ([col (add1 (length empty-columns))]) + (set! store (make-store (add1 col))) + (set! empty-columns (cons "" empty-columns)) + (set! itemss + (for/list ([items (in-list itemss)]) + (append items (list "")))) + (gtk_tree_view_set_model client-gtk store) + (let ([renderer (gtk_cell_renderer_text_new)]) + (gtk_tree_view_column_new_with_attributes + label + renderer + "text" + col + #f)) + (let ([column-gtk (make-column label col)]) + (g_object_set_data column-gtk "wx" (g_object_get_data client-gtk "wx")) + (set! column-gtks (append column-gtks (list column-gtk))) + (gtk_tree_view_append_column client-gtk column-gtk) + (reset-content) + (column-finish column-gtk)))) + + (define/public (delete-column i) + (define (remove-nth l i) + (cond + [(zero? i) (cdr l)] + [else (cons (car l) (remove-nth (cdr l) (sub1 i)))])) + (set! empty-columns (cdr empty-columns)) + (set! itemss + (for/list ([items (in-list itemss)]) + (remove-nth items i))) + (let ([old (list-ref column-gtks i)]) + (set! column-gtks (remove-nth column-gtks i)) + (gtk_tree_view_remove_column client-gtk old)) + (for ([column-gtk (in-list column-gtks)] + [pos (in-naturals)]) + (when (pos . >= . i) + (gtk_tree_view_column_set_attributes column-gtk + renderer + "text" + pos + #f))) + (gtk_list_store_clear store) + (reset-content)) + (atomically (reset-content))) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index f83e86d3ac..72a5a9fbf3 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -157,7 +157,7 @@ (define/override (is-command? cmd) (= cmd BN_CLICKED)) - (define/public (do-command cmd control-hwnd) + (define/override (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 962655bc69..e3f3044d0a 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -495,7 +495,7 @@ (or (= cmd CBN_SELENDOK) (= cmd CBN_DROPDOWN))) - (define/public (do-command cmd control-hwnd) + (define/override (do-command cmd control-hwnd) (cond [(= cmd CBN_SELENDOK) (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index b189c0a9a0..d26a3525bf 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -81,7 +81,7 @@ (set! choice-dropped? #f)))) (= cmd CBN_SELENDOK)) - (define/public (do-command cmd control-hwnd) + (define/override (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 8f572f54a3..ab6dc02fb7 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -46,38 +46,219 @@ (define LB_GETSEL #x0187) (define LB_SELITEMRANGE #x019B) +(define LVCF_WIDTH #x0002) +(define LVCF_TEXT #x0004) +(define LVCF_MINWIDTH #x0040) + +(define LVS_REPORT #x0001) +(define LVS_SINGLESEL #x0004) +(define LVS_NOCOLUMNHEADER #x4000) +(define LVS_SHOWSELALWAYS #x0008) + +(define LVS_EX_HEADERDRAGDROP #x00000010) +(define LVS_EX_FULLROWSELECT #x00000020) + +(define LVIF_TEXT #x0001) +(define LVIF_DI_SETITEM #x1000) + +(define LVM_FIRST #x1000) +(define LVM_INSERTITEMW (+ LVM_FIRST 77)) +(define LVM_GETSTRINGWIDTHW (+ LVM_FIRST 87)) +(define LVM_INSERTCOLUMNW (+ LVM_FIRST 97)) +(define LVM_DELETECOLUMN (+ LVM_FIRST 28)) +(define LVM_SETCOLUMNW (+ LVM_FIRST 96)) +(define LVM_GETCOLUMNW (+ LVM_FIRST 95)) +(define LVM_SETITEMTEXTW (+ LVM_FIRST 116)) +(define LVM_DELETEALLITEMS (+ LVM_FIRST 9)) +(define LVM_GETTOPINDEX (+ LVM_FIRST 39)) +(define LVM_GETCOUNTPERPAGE (+ LVM_FIRST 40)) +(define LVM_ENSUREVISIBLE (+ LVM_FIRST 19)) +(define LVM_DELETEITEM (+ LVM_FIRST 8)) +(define LVM_GETSELECTEDCOUNT (+ LVM_FIRST 50)) +(define LVM_GETNEXTITEM (+ LVM_FIRST 12)) +(define LVM_GETITEMSTATE (+ LVM_FIRST 44)) +(define LVM_SETITEMSTATE (+ LVM_FIRST 43)) +(define LVM_SETEXTENDEDLISTVIEWSTYLE (+ LVM_FIRST 54)) +(define LVM_SETCOLUMNORDERARRAY (+ LVM_FIRST 58)) +(define LVM_GETCOLUMNORDERARRAY (+ LVM_FIRST 59)) + +(define LVN_FIRST -100) +(define LVN_ITEMCHANGED (- LVN_FIRST 1)) +(define LVN_COLUMNCLICK (- LVN_FIRST 8)) + +(define NM_FIRST 0) +(define NM_DBLCLK (- NM_FIRST 3)) + +(define LVNI_SELECTED #x0002) +(define LVIS_SELECTED #x0002) + +(define-cstruct _LVCOLUMN + ([mask _UINT] + [fmt _int] + [cx _int] + [pszText _permanent-string/utf-16] + [cchTextMax _int] + [iSubItem _int] + [iImage _int] + [iOrder _int] + [cxMin _int] + [cxDefault _int] + [cxIdeal _int])) + +(define (make-lvcolumn flags label) + (make-LVCOLUMN flags + 0 0 + label + 0 0 0 0 0 0 0)) + +(define (free-lvcolumn lv) + (let ([s (LVCOLUMN-pszText lv)]) + (when s (free s)))) + +(define column-desc (cast (malloc (ctype-sizeof _LVCOLUMN) 'raw) + _pointer + _LVCOLUMN-pointer)) +(memset column-desc 0 (ctype-sizeof _LVCOLUMN)) + +;; Microsoft docs say to add padding to a ListView +;; item's width, but it doesn't say how much padding: +(define COLUMN-PADDING 16) + +(define-cstruct _LVITEM + ([mask _UINT] + [iItem _int] + [iSubItem _int] + [state _UINT] + [stateMask _UINT] + [pszText _permanent-string/utf-16] + [cchTextMax _int] + [iImage _int] + [lParam _LPARAM] + [iIndent _int] + [iGroupId _int] + [cColumns _UINT] + [puColumns _UINT] + [piColFmt _int] + [iGroup _int])) + +(define (make-lvitem flags pos col label) + (make-LVITEM flags + pos col + 0 0 ; state & statemask + label + 0 0 + 0 ; lParam + 0 0 0 + 0 0 0)) + +(define (free-lvitem lv) + (let ([s (LVITEM-pszText lv)]) + (when s (free s)))) + +(define-cstruct _NMLISTVIEW + ([hdr _NMHDR] + [iItem _int] + [iSubItem _int] + ;; .... + )) + +;; ------------------------------------------------------------ + (define list-box% (class item% (init parent cb label kind x y w h choices style - font label-font) + font label-font + columns column-order) (inherit set-size set-control-font get-client-size) + (define num-columns (length columns)) + (define single-column? (and (= 1 num-columns) + (not (memq 'column-headers style)) + (not (memq 'variable-columns style)))) (define single? (eq? 'single kind)) (define hwnd (CreateWindowExW/control WS_EX_CLIENTEDGE - "PLTLISTBOX" + (if single-column? + "PLTLISTBOX" + "PLTSysListView32") label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY - WS_VSCROLL - (if (memq 'hscroll style) WS_HSCROLL 0) - (cond - ;; Win32 sense of "multiple" and "extended" is backwards - [(eq? kind 'extended) LBS_MULTIPLESEL] - [(eq? kind 'multiple) LBS_EXTENDEDSEL] - [else 0])) + (if single-column? + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] + [else 0])) + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + LVS_REPORT + (if (memq 'column-headers style) + 0 + LVS_NOCOLUMNHEADER) + LVS_SHOWSELALWAYS + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + [(eq? kind 'extended) 0] + [(eq? kind 'multiple) 0] + [else LVS_SINGLESEL]))) 0 0 0 0 (send parent get-client-hwnd) #f hInstance #f)) - (for ([s (in-list choices)]) - (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + (when single-column? + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s))) + + (unless single-column? + (for ([label (in-list columns)] + [col (in-naturals)]) + (atomically + (let ([col-desc (make-lvcolumn LVCF_TEXT label)]) + (SendMessageW/ptr hwnd LVM_INSERTCOLUMNW col col-desc) + (free-lvcolumn col-desc))) + (let* ([label-width + (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label)] + [max-width + (if (zero? col) + ;; size column based on the content: + (for/fold ([w label-width]) ([s (in-list choices)] + [i (in-naturals)]) + (atomically + (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM + LVIF_TEXT) + i + col + s)]) + (if (zero? col) + (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv) + (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv)) + (free-lvitem lv))) + (max w + (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 s))) + ;; size column based on the label, only: + label-width)]) + (let ([col-desc (make-lvcolumn LVCF_WIDTH #f)]) + (set-LVCOLUMN-cx! col-desc (+ max-width COLUMN-PADDING)) + (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc))))) + + (unless single-column? + (SendMessageW hwnd LVM_SETEXTENDEDLISTVIEWSTYLE 0 + (bitwise-ior LVS_EX_FULLROWSELECT + (if (memq 'reorderable-headers style) + LVS_EX_HEADERDRAGDROP + 0)))) + + (when column-order + (set-column-order column-order)) (super-new [callback cb] [parent parent] @@ -90,19 +271,50 @@ (define callback cb) (define/override (is-command? cmd) - (or (= cmd LBN_SELCHANGE) - (= cmd LBN_DBLCLK))) + (if single-column? + (or (= cmd LBN_SELCHANGE) + (= cmd LBN_DBLCLK)) + (or (= cmd LVN_ITEMCHANGED) + (= cmd NM_DBLCLK) + (= cmd LVN_COLUMNCLICK)))) + + (define pending-changed (box #f)) + (define/override (do-command cmd control-hwnd) + ;; LVN_ITEMCHANGED notifications, in particular, get + ;; set for each item that changes in a selection change. + ;; Use a box to cancel pending callbacks to collapse the + ;; multiple callbacks into one. + (set-box! pending-changed #f) + (let ([b (box #t)] + [t (if (if single-column? + (= cmd LBN_SELCHANGE) + (= cmd LVN_ITEMCHANGED)) + 'list-box + 'list-box-dclick)]) + (unless (eq? t 'list-box-dclick) + (set! pending-changed b)) + (queue-window-event + this + (lambda () + (when (unbox b) + (callback this + (new control-event% + [event-type t] + [time-stamp (current-milliseconds)]))))))) + + (define/override (do-command-ex cmd control-hwnd nmhdr) + (if (and (not single-column?) + (= cmd LVN_COLUMNCLICK)) + (let ([col (NMLISTVIEW-iSubItem + (cast nmhdr _pointer _NMLISTVIEW-pointer))]) + (queue-window-event this (lambda () + (callback this + (new column-control-event% + [column col] + [event-type 'list-box-column] + [time-stamp (current-milliseconds)]))))) + (super do-command-ex cmd control-hwnd nmhdr))) - (define/public (do-command cmd control-hwnd) - (queue-window-event this (lambda () - (callback this - (new control-event% - [event-type (if (= cmd LBN_SELCHANGE) - 'list-box - 'list-box-dclick)] - [time-stamp (current-milliseconds)]))))) - - (define num (length choices)) (define/public (number) num) @@ -110,37 +322,138 @@ (define/public (get-data i) (unbox (list-ref data i))) (define/public (set-data i v) (set-box! (list-ref data i) v)) - (define/public (set-string i str) + (define/public (set-string i str [col 0]) (atomically - (SendMessageW/str hwnd LB_INSERTSTRING i str) - (SendMessageW hwnd LB_DELETESTRING (add1 i) 0) + (if single-column? + (begin + (SendMessageW/str hwnd LB_INSERTSTRING i str) + (SendMessageW hwnd LB_DELETESTRING (add1 i) 0)) + (let ([lv (make-lvitem 0 + 0 + col + str)]) + (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv) + (free-lvitem lv))) (void))) + + (define/public (set-column-order column-order) + (unless single-column? + (let* ([count num-columns] + [a (malloc _int count)]) + (for ([n (in-list column-order)] + [i (in-range count)]) + (ptr-set! a _int i n)) + (SendMessageW/ptr hwnd LVM_SETCOLUMNORDERARRAY count a) + (InvalidateRect hwnd #f #f)))) + + (define/public (get-column-order) + (if single-column? + '(0) + (let* ([count num-columns] + [a (malloc _int count)]) + (SendMessageW/ptr hwnd LVM_GETCOLUMNORDERARRAY count a) + (cast a _pointer (_list o _int count))))) + + (define/public (set-column-label col s) + (unless single-column? + (atomically + (let ([col-desc (make-lvcolumn LVCF_TEXT s)]) + (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc) + (free-lvcolumn col-desc))))) + + (define min-col-width 0) ; not kept for us by XP + (define max-col-width 10000) + (define/public (set-column-size col w mn mx) + (if single-column? + (atomically + (set! min-col-width mn) + (set! max-col-width mx)) + (atomically + (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)]) + (set-LVCOLUMN-cx! col-desc w) + (set-LVCOLUMN-cxMin! col-desc mn) + (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc) + (set! min-col-width mn) + (set! max-col-width mx))))) + + (define/public (get-column-size col) + (atomically + (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)]) + (SendMessageW/ptr hwnd LVM_GETCOLUMNW col col-desc) + (let ([v (LVCOLUMN-cx col-desc)]) + (values (max v min-col-width) ; in XP, may have been sized too small + min-col-width + max-col-width))))) + + (define/public (append-column label) + (atomically + (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_TEXT + LVCF_WIDTH) + label)]) + (set-LVCOLUMN-cx! col-desc + (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label)) + (SendMessageW/ptr hwnd LVM_INSERTCOLUMNW num-columns col-desc) + (free-lvcolumn col-desc)) + (set! num-columns (add1 num-columns)))) + + (define/public (delete-column col) + (atomically + (SendMessageW hwnd LVM_DELETECOLUMN col 0) + (set! num-columns (sub1 num-columns)))) + (define/public (set-first-visible-item i) - (void (SendMessageW hwnd LB_SETTOPINDEX i 0))) + (if single-column? + (void (SendMessageW hwnd LB_SETTOPINDEX i 0)) + (let ([c (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)]) + (unless (= c i) + (if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0) + i) + (void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0)) + (void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0))))))) (define/public (get-first-item) - (SendMessageW hwnd LB_GETTOPINDEX 0 0)) + (SendMessageW hwnd (if single-column? LB_GETTOPINDEX LVM_GETTOPINDEX) 0 0)) (define/public (number-of-visible-items) - (let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)]) - (let ([w (box 0)] - [h (box 0)]) - (get-client-size w h) - (quotient (unbox h) ih)))) + (if single-column? + (let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)]) + (let ([w (box 0)] + [h (box 0)]) + (get-client-size w h) + (quotient (unbox h) ih))) + (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0))) (define/public (clear) (atomically (set! data null) (set! num 0) - (void (SendMessageW hwnd LB_RESETCONTENT 0 0)))) + (void (SendMessageW hwnd (if single-column? + LB_RESETCONTENT + LVM_DELETEALLITEMS) + 0 0)))) - (define/public (set choices) + (define/public (set choices . more-choices) (atomically (ShowWindow hwnd SW_HIDE) (clear) - (for ([s (in-list choices)]) - (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + (if single-column? + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + (for ([choices (in-list (cons choices more-choices))] + [col (in-naturals)]) + (for ([s (in-list choices)] + [i (in-naturals)]) + (atomically + (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM + LVIF_TEXT) + i + col + s)]) + (if (zero? col) + (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv) + (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv)) + (free-lvitem lv)))))) (set! data (map (lambda (s) (box #f)) choices)) (set! num (length choices)) (ShowWindow hwnd SW_SHOW))) @@ -148,7 +461,15 @@ (public [append* append]) (define (append* s [v #f]) (atomically - (SendMessageW/str hwnd LB_ADDSTRING 0 s) + (if single-column? + (SendMessageW/str hwnd LB_ADDSTRING 0 s) + (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM + LVIF_TEXT) + num + 0 + s)]) + (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv) + (free-lvitem lv))) (set! num (add1 num)) (set! data (append data (list (box v)))))) @@ -156,25 +477,35 @@ (atomically (set! data (append (take data i) (drop data (add1 i)))) (set! num (sub1 num)) - (void (SendMessageW hwnd LB_DELETESTRING i 0)))) + (void (SendMessageW hwnd (if single-column? + LB_DELETESTRING + LVM_DELETEITEM) + i 0)))) (define/public (get-selections) (atomically - (if single? - (let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)]) - (if (= v LB_ERR) - null - (list v))) - (let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)]) - (if (zero? n) - null - (let ([selections (malloc n _LONG 'raw)]) - (SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM)) - (begin0 - (for/list ([i (in-range n)]) - (ptr-ref selections _LONG i)) - (free selections)))))))) - + (if single-column? + (if single? + (let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)]) + (if (= v LB_ERR) + null + (list v))) + (let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)]) + (if (zero? n) + null + (let ([selections (malloc n _LONG 'raw)]) + (SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM)) + (begin0 + (for/list ([i (in-range n)]) + (ptr-ref selections _LONG i)) + (free selections)))))) + (let loop ([c (SendMessageW hwnd LVM_GETSELECTEDCOUNT 0 0)] + [pos -1]) + (cond + [(zero? c) null] + [else (let ([pos (SendMessageW hwnd LVM_GETNEXTITEM pos LVNI_SELECTED)]) + (cons pos (loop (sub1 c) pos)))]))))) + (define/public (get-selection) (let ([l (get-selections)]) (if (null? l) @@ -182,16 +513,28 @@ (car l)))) (define/public (selected? i) - (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) + (if single-column? + (not (zero? (SendMessageW hwnd LB_GETSEL i 0))) + (not (zero? (SendMessageW hwnd LVM_GETITEMSTATE i LVIS_SELECTED))))) (define/public (select i [on? #t] [one? #t]) (void - (if single? - (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) - (begin - (unless one? - (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) - (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))) + (if single-column? + (if single? + (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) + (begin + (unless one? + (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) + (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))) + (let ([lv (make-lvitem 0 0 0 #f)]) + (define (set-one i on?) + (set-LVITEM-stateMask! lv LVIS_SELECTED) + (set-LVITEM-state! lv (if on? LVIS_SELECTED 0)) + (SendMessageW/ptr hwnd LVM_SETITEMSTATE i lv)) + (when (and on? (not single?) (not one?)) + (for ([i (in-list (get-selections))]) + (set-one i #f))) + (set-one i on?))))) (define/public (set-selection i) (void (select i #t #f))) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 329f5c8616..fab16f6e7b 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -108,7 +108,7 @@ (define/override (is-command? cmd) (= cmd BN_CLICKED)) - (define/public (do-command cmd control-hwnd) + (define/override (do-command cmd control-hwnd) (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)] [pos (in-naturals)]) (if (ptr-equal? control-hwnd radio-hwnd) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index aa66b2ad29..29786147ce 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -114,7 +114,7 @@ (define/override (is-command? cmd) (= cmd -551)) - (define/public (do-command cmd control-hwnd) + (define/override (do-command cmd control-hwnd) (queue-window-event this (lambda () (callback this (new control-event% diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index ccff4d19be..f9a288957a 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -22,7 +22,7 @@ GetWindowLongPtrW SetWindowLongPtrW - SendMessageW SendMessageW/str + SendMessageW SendMessageW/str SendMessageW/ptr GetSysColor GetRValue GetGValue GetBValue make-COLORREF CreateBitmap CreateCompatibleBitmap @@ -82,6 +82,8 @@ (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) #:c-id SendMessageW) +(define-user32 SendMessageW/ptr (_wfun _HWND _UINT _WPARAM _pointer -> _LRESULT) + #:c-id SendMessageW) (define-user32 GetSysColor (_wfun _int -> _DWORD)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 28c33bee1a..0f34e355fc 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -28,7 +28,9 @@ get-default-control-font GetWindowRect - GetClientRect)) + GetClientRect + + _NMHDR)) (define (unhide-cursor) (void)) @@ -213,7 +215,7 @@ [cmd (LOWORD (NMHDR-code nmhdr))]) (if (and wx (send wx is-command? cmd)) (begin - (send wx do-command cmd control-hwnd) + (send wx do-command-ex cmd control-hwnd nmhdr) 0) (default w msg wParam lParam)))] [(or (= msg WM_HSCROLL) @@ -246,6 +248,11 @@ (define/public (is-command? cmd) #f) (define/public (control-scrolled) #f) + (define/public (do-command cmd control-hwnd) + (void)) + (define/public (do-command-ex cmd control-hwnd nmhdr) + (do-command cmd control-hwnd)) + (define/public (show on?) (when on? (show-children)) (atomically (direct-show on?))) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 880209d60a..127bbea1b6 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -307,3 +307,4 @@ (register-no-cursor "msctls_trackbar32") (register-no-cursor "msctls_progress32") (register-no-cursor "SysTabControl32") +(register-no-cursor "SysListView32") diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 0dbad4c0de..3a28522b72 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -48,9 +48,9 @@ (define (filter-style style) (remq 'deleted style)) - (define-syntax-rule (bounce c (m arg ...) ...) + (define-syntax-rule (bounce c (m . args) ...) (begin - (define/public m (lambda (arg ...) (send c m arg ...))) + (define/public m (lambda args (send c m . args))) ...)) ;; ---------------------------------------- @@ -121,7 +121,8 @@ (define wx-internal-list-box% (make-window-glue% - (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font) + (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font + label-font columns column-order) (inherit get-first-item set-first-visible-item) (private @@ -147,23 +148,24 @@ [(wheel-up) (scroll -1) #t] [(wheel-down) (scroll 1) #t] [else #f])))]) - (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) + (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font + label-font columns column-order))))) (define wx-list-box% (class wx-label-panel% - (init mred proxy parent cb label kind x y w h choices style font label-font) + (init mred proxy parent cb label kind x y w h choices style font label-font columns column-order) (inherit get-p set-c) (super-init proxy parent label style font 'left 'top) (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices - (filter-style style) font label-font)) + (filter-style style) font label-font columns column-order)) (set-c c #t #t) (bounce c (get-label-font) - (set-string i s) + (set-string i s col) (set-selection i) (get-selection) (get-selections) @@ -178,8 +180,15 @@ (selected? i) (delete i) (clear) - (set choices) - (reset)) + (set choices . more) + (reset) + (get-column-order) + (set-column-order l) + (set-column-label i l) + (set-column-size i w mn mx) + (get-column-size i) + (delete-column i) + (append-column l)) (define/public select (case-lambda [(i) (send c select i)] diff --git a/collects/scribblings/gui/column-control-event-class.scrbl b/collects/scribblings/gui/column-control-event-class.scrbl new file mode 100644 index 0000000000..cba744bfb2 --- /dev/null +++ b/collects/scribblings/gui/column-control-event-class.scrbl @@ -0,0 +1,28 @@ +#lang scribble/doc +@(require "common.ss") + +@defclass/title[column-control-event% control-event% ()]{ + +A @scheme[column-control-event%] object contains information about a + event on an @racket[list-box%] column header. + +@defconstructor[([column exact-nonnegative-integer?] + [event-type (one-of/c 'list-box-column)] + [time-stamp exact-integer? 0])]{ + +The @racket[column] argument indicates the column that was clicked. +} + +@defmethod[(get-column) exact-nonnegative-integer?]{ + +Returns the column number (counting from 0) of the clicked column. +} + +@defmethod[(set-column + [column exact-nonnegative-integer?]) + void?]{ + + +Sets the column number (counting from 0) of the clicked column. + +}} diff --git a/collects/scribblings/gui/control-event-class.scrbl b/collects/scribblings/gui/control-event-class.scrbl index 6e60a54532..3b9de3a8f1 100644 --- a/collects/scribblings/gui/control-event-class.scrbl +++ b/collects/scribblings/gui/control-event-class.scrbl @@ -8,9 +8,10 @@ A @scheme[control-event%] object contains information about a provided to a control or menu item callback procedure. @defconstructor[([event-type (one-of/c 'button 'check-box 'choice - 'list-box 'list-box-dclick 'text-field - 'text-field-enter 'slider 'radio-box - 'menu-popdown 'menu-popdown-none 'tab-panel)] + 'list-box 'list-box-dclick 'list-box-column + 'text-field 'text-field-enter + 'slider 'radio-box 'tab-panel + 'menu-popdown 'menu-popdown-none)] [time-stamp exact-integer? 0])]{ The @scheme[event-type] argument is one of the following: @@ -20,14 +21,16 @@ The @scheme[event-type] argument is one of the following: @item{@scheme['choice] --- for @scheme[choice%] item selections} @item{@scheme['list-box] --- for @scheme[list-box%] selections and deselections} @item{@scheme['list-box-dclick] --- for @scheme[list-box%] double-clicks} +@item{@scheme['list-box-column] --- for @scheme[list-box%] column clicks in + a @racket[column-control-event%] instance} @item{@scheme['text-field] --- for @scheme[text-field%] changes} @item{@scheme['text-field-enter] --- for single-line @scheme[text-field%] Enter event} @item{@scheme['menu] --- for @scheme[selectable-menu-item<%>] callbacks} @item{@scheme['slider] --- for @scheme[slider%] changes} @item{@scheme['radio-box] --- for @scheme[radio-box%] selection changes} +@item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes} @item{@scheme['menu-popdown] --- for @scheme[popup-menu%] callbacks (item selected)} @item{@scheme['menu-popdown-none] --- for @scheme[popup-menu%] callbacks (no item selected)} -@item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes} ] This value is extracted out of a @scheme[control-event%] object with diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index de1351e699..ec34ddee53 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require "common.ss") -@(define lbnumnote @elem{List box items are indexed from @scheme[0].}) +@(define lbnumnote @elem{List box rows are indexed from @scheme[0].}) +@(define lbcnumnote @elem{List box rows and columns are indexed from @scheme[0].}) @defclass/title[list-box% object% (list-control<%>)]{ @@ -16,7 +17,14 @@ Whenever the user changes the selection in a list box, the list box's callback procedure is called. A callback procedure is provided as an initialization argument when each list box is created. -@|lbnumnote| +A list box can have multiple columns with optional column headers. An + item in the list corresponds to a row that spans all columns. When + column headers are displayed, the column widths can be changed by a + user. In addition, columns can optionally support dragging by the + user to change the display order of columns, while the logical order + remains fixed. + +@|lbcnumnote| See also @scheme[choice%]. @@ -30,6 +38,8 @@ See also @scheme[choice%]. (lambda (c e) (void))] [style (listof (one-of/c 'single 'multiple 'extended 'vertical-label 'horizontal-label + 'variable-columns 'column-headers + 'clickable-headers 'reorderable-headers 'deleted)) '(single)] [selection (or/c exact-nonnegative-integer? false/c) #f] @@ -41,7 +51,10 @@ See also @scheme[choice%]. [min-width (integer-in 0 10000) _graphical-minimum-width] [min-height (integer-in 0 10000) _graphical-minimum-height] [stretchable-width any/c #t] - [stretchable-height any/c #t])]{ + [stretchable-height any/c #t] + [columns (cons/c label-string? (listof label-string?)) + '("Column")] + [column-order (or/c #f (listof exact-nonnegative-integer?)) #f])]{ If @scheme[label] is not @scheme[#f], it is used as the list box label. Otherwise, the list box will not display its label. @@ -49,7 +62,9 @@ If @scheme[label] is not @scheme[#f], it is used as the list box @labelstripped[(scheme label) @elem{} @elem{move the keyboard focus to the list box}] The @scheme[choices] list specifies the initial list of items - to appear in the list box. + to appear in the list box. If the list box has multiple columns, + @racket[choices] determines the content of the first column, and + other columns are initialized to the empty string. The @scheme[callback] procedure is called when the user changes the list box selection, by either selecting, re-selecting, deselecting, or @@ -57,6 +72,14 @@ The @scheme[callback] procedure is called when the user changes the list callback is @indexed-scheme['list-box-dclick] when the user double-clicks on an item, or @indexed-scheme['list-box] otherwise. +The @racket[columns] list determines the number of columns in the list + box. The column titles in @racket[columns] are shown only if + @racket[style] includes @racket['column-headers]. If @racket[style] + also includes @racket['clickable-headers], then a click on a header + triggers a call to @racket[callback] with a + @racket[column-control-event%] argument whose event type is + @indexed-scheme['list-box-column]. + The @scheme[style] specification must include exactly one of the following: @itemize[ @@ -85,17 +108,29 @@ The @scheme['multiple] and @scheme['extended] styles determine a @HVLabelNote[@scheme[style]]{list box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{list box} +If @racket[style] includes @racket['variable-columns], then the number +of columns in the list box can be changed via @method[list-box% append-column] +and @method[list-box% delete-column]. + If @scheme[selection] is an integer, it is passed to @method[list-control<%> set-selection] to set the initial selection. The @scheme[selection] must be less than the length of @scheme[choices]. @FontLabelKWs[@scheme[font] @scheme[label-font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] +It the @racket[column-order] argument is not @racket[#f], it +determines the order in which logical columns are initially displayed. See +@method[list-box% set-column-order] for more information. If +@racket[style] includes @racket['column-headers] and +@racket['reorderable-headers], then a user can reorder columns as +displayed (but the display order does not change the logical order of +the columns). + } @defmethod[#:mode override - (append [item string] + (append [item label-string?] [data any/c #f]) void?]{ @@ -110,6 +145,15 @@ See also @xmethod[list-control<%> append]. } +@defmethod[(append-column [label label-string?]) + void?]{ + +Adds a new column with title @racket[label] to the list box, but only +if the list box is created with the @racket['variable-columns] +style. The new column is logically the last column, and it is initially +displayed as the last column.} + + @defmethod[(delete [n exact-nonnegative-integer?]) void?]{ @@ -117,9 +161,47 @@ Deletes the item indexed by @scheme[n]. @|lbnumnote| If @scheme[n] is equal to or larger than the number of items in the control, @|MismatchExn|. Selected items that are not deleted remain selected, and no other - items are selected. + items are selected.} + + +@defmethod[(delete-column [n exact-nonnegative-integer?]) + void?]{ + +Deletes the column with logical position @racket[n], but only if the +list box is created with the @racket['variable-columns] style, and +only if the list box currently has more than one column (i.e., the +number of columns can never be zero).} + + +@defmethod[(get-column-labels) (cons/c label-string? (listof label-string?))]{ + +Returns the labels of the list box's columns, and the number of +returned strings indicates the number of columns in the list box.} + + +@defmethod[(get-column-order) (listof exact-nonnegative-integer?)]{ + +Returns the display order of logical columns. Each column is +represented by its logical position in the result list, and the order +of the column positions indicates the display order. + +See also @method[list-box% set-column-order].} + + +@defmethod[(get-column-width [column exact-nonnegative-integer?]) + (values exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer?)]{ + +Gets the width of the column identified by @racket[column] (in logical +positions, as opposed to display positions), which must be between 0 +and one less than the number of columns. + +The result includes the column's current width as well as its minimum +and maximum widths to constrain the column size as adjusted by a user. + +See also @method[list-box set-column-width].} -} @defmethod[(get-data [n exact-nonnegative-integer?]) any/c]{ @@ -165,7 +247,7 @@ For single-selection lists, the result is always either @scheme[null] or @defmethod[(is-selected? [n exact-nonnegative-integer?]) boolean?]{ -Returns @scheme[#t] if the item index by @scheme[n] is selected, +Returns @scheme[#t] if the items indexed by @scheme[n] is selected, @scheme[#f] otherwise. @|lbnumnote| If @scheme[n] is equal to or larger than the number of choices, @|MismatchExn|. @@ -204,12 +286,55 @@ The control's callback procedure is @italic{not} invoked. } -@defmethod[(set [choices (listof label-string?)]) +@defmethod[(set [choices (listof label-string?)] + ...) void?]{ -Clears the list box and installs a new list of items. +Clears the list box and installs a new list of items. The number of +@racket[choices] lists must match the number of columns, and all +@racket[choices] lists must have the same number of items, otherwise +@|MismatchExn|.} -} + +@defmethod[(set-column-label [column exact-nonnegative-integer?] + [label label-string?]) + void?]{ + +Sets the label of the column identified by @racket[column] (in logical +positions, as opposed to display positions), which must be between 0 +and one less than the number of columns.} + + +@defmethod[(set-column-order [column-order (listof exact-nonnegative-integer?)]) + void?]{ + +Sets the order in which logical columns are displayed. Each element of +@racket[column-order] must identify a unique column by its logical +position, and all logical columns must be represented in the list. + +See also @method[list-box% get-column-order].} + + +@defmethod[(set-column-width [column exact-nonnegative-integer?] + [width exact-nonnegative-integer?] + [min-width exact-nonnegative-integer?] + [max-width exact-nonnegative-integer?]) + void?]{ + +Sets the width of the column identified by @racket[column] (in logical +positions, as opposed to display positions), which must be between 0 +and one less than the number of columns. + +The @racket[width] argument sets the current display width, while +@racket[min-width] and @racket[max-width] constrain the width of the +column when the user resizes it. The @racket[width] argument must be +no less than @racket[min-width] and no more than @racket[max-width]. + +The default width of a column is platform-specific, and the last +column of a list box may extend to the end of the control independent +of its requested size. + +See also @method[list-box% get-column-width].} @defmethod[(set-data [n exact-nonnegative-integer?] @@ -239,11 +364,14 @@ Scrolls the list box so that the item indexed by @scheme[n] is at the @defmethod[(set-string [n exact-nonnegative-integer?] - [label label-string?]) + [label label-string?] + [column exact-nonnegative-integer? 0]) void?]{ -Sets the item indexed by @scheme[n]. @|lbnumnote| If @scheme[n] is -equal to or larger than the number of choices, @|MismatchExn|. +Sets the item indexed by @scheme[n] in logical column @racket[column]. +@|lbcnumnote| If @scheme[n] is +equal to or larger than the number of choices, or if @racket[column] +is equal to or larger than the number of columns, @|MismatchExn|. } } diff --git a/collects/scribblings/gui/list-control-intf.scrbl b/collects/scribblings/gui/list-control-intf.scrbl index e5d4fbe5d6..201233c2bd 100644 --- a/collects/scribblings/gui/list-control-intf.scrbl +++ b/collects/scribblings/gui/list-control-intf.scrbl @@ -22,7 +22,7 @@ In either case, the set of user-selectable items can be changed -@defmethod[(append [item string]) +@defmethod[(append [item label-string?]) void?]{ Adds a new item to the list of user-selectable items. The current selection is unchanged (unless the list control is an empty choice diff --git a/collects/scribblings/gui/win-classes.scrbl b/collects/scribblings/gui/win-classes.scrbl index afa5b9edeb..0ecb0bbd9e 100644 --- a/collects/scribblings/gui/win-classes.scrbl +++ b/collects/scribblings/gui/win-classes.scrbl @@ -33,6 +33,7 @@ Alphabetical: @include-section["clipboard-intf.scrbl"] @include-section["combo-field-class.scrbl"] @include-section["control-intf.scrbl"] +@include-section["column-control-event-class.scrbl"] @include-section["control-event-class.scrbl"] @include-section["cursor-class.scrbl"] @include-section["dialog-class.scrbl"] diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index d946bf1866..f1f927d3f1 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1,4 +1,4 @@ -#lang scheme/gui +#lang racket/gui (require mzlib/class mzlib/class100 @@ -1402,7 +1402,8 @@ (instructions p "radiobox-steps.txt") (send f show #t)) -(define (choice-or-list-frame list? list-style empty?) +(define (choice-or-list-frame list? list-style empty? + [columns '("Choice")] [more-styles '()] [column-order #f]) (define f (make-frame frame% (if list? "List Test" "Choice Test"))) (define p f) (define-values (actual-content actual-user-data) @@ -1412,7 +1413,10 @@ (list #f #f #f)))) (define commands (if list? - (list 'list-box 'list-box-dclick) + (append (list 'list-box 'list-box-dclick) + (if (memq 'clickable-headers more-styles) + (list 'list-box-column) + null)) (list 'choice))) (define old-list null) (define multi? (or (memq 'multiple list-style) @@ -1428,6 +1432,8 @@ (printf "Double-click\n") (unless (send cx get-selection) (error "no selection for dclick"))] + [(eq? (send e get-event-type) 'list-box-column) + (printf "Column: ~a\n" (send e get-column))] [else ; misc multi-selection (printf "Changed: ~a\n" (if list? @@ -1435,12 +1441,21 @@ (send cx get-selection)))]) (check-callback-event c cx e commands #f))) (define c (if list? - (make-object list-box% "Tester" actual-content p callback list-style) + (new list-box% [label "Tester"] + [choices actual-content] + [parent p] + [callback callback] + [style (append list-style more-styles)] + [columns columns] + [column-order column-order]) (make-object choice% "Tester" actual-content p callback))) (define counter 0) (define append-with-user-data? #f) + (define ap (new horizontal-panel% [parent p] + [stretchable-width #f] + [stretchable-height #f])) (define ab (make-object button% - "Append" p + "Append" ap (lambda (b e) (set! counter (add1 counter)) (let ([naya (format "~aExtra ~a" @@ -1463,14 +1478,55 @@ naya-data)))) (set! append-with-user-data? (not append-with-user-data?)))))) - (define cs (when list? - (make-object button% - "Visible Indices" p - (lambda (b e) - (printf "top: ~a\nvisible count: ~a\n" - (send c get-first-visible-item) - (send c number-of-visible-items)))))) - (define cdp (make-object horizontal-panel% p)) + (new button% + [label "Add Column"] + [parent ap] + [callback (lambda (b e) + (let ([s (format "New ~a" (length columns))]) + (send c append-column s) + (set! columns (append columns (list s)))))]) + (new button% + [label "Delete Right Column"] + [parent ap] + [callback (lambda (b e) + (let ([pos (last (send c get-column-order))]) + (send c delete-column pos) + (set! columns (send c get-column-labels))))]) + (when list? + (let ([hp (new horizontal-panel% + [parent p] + [stretchable-width #f] + [stretchable-height #f])]) + (make-object button% + "Visible Indices" hp + (lambda (b e) + (printf "top: ~a\nvisible count: ~a\n" + (send c get-first-visible-item) + (send c number-of-visible-items)))) + (define (mk which pos) + (new button% [label (format "Set ~a Top" which)] + [parent hp] + [callback (lambda (b e) (send c set-first-visible-item pos))])) + (mk "First" 0) + (mk "Third" 2) + (mk "Tenth" 9) + (new button% [label "Reverse Columns"] + [parent hp] + [callback (lambda (b e) (send c set-column-order (reverse (send c get-column-order))))]) + (new button% [label "Set Column Label"] + [parent hp] + [callback (lambda (b e) + (send c set-column-label (sub1 (length columns)) "Last") + (send c set-column-label 0 "First"))]) + (new button% [label "Set Column Size"] + [parent hp] + [callback (lambda (b e) + (send c set-column-size 0 50 10 100) + (unless (= 1 (length columns)) + (let-values ([(w mn mx) (send c get-column-size 0)]) + (send c set-column-size (sub1 (length columns)) w mn mx))))]))) + (define cdp (new horizontal-panel% [parent p] + [stretchable-height #f])) (define rb (make-object button% "Clear" cdp (lambda (b e) (set! actual-content null) @@ -1510,7 +1566,11 @@ (make-object button% "Reset" cdp (lambda (b e) - (send c set '("Alpha" "Beta" "Gamma")) + (let ([extras (for/list ([in-list (cdr columns)] + [col (in-naturals 1)]) + (for/list ([i (in-range 3)]) + (format "~a, ~a" col i)))]) + (send c set '("Alpha" "Beta" "Gamma") . extras)) (set! actual-content '("Alpha" "Beta" "Gamma")) (set! actual-user-data (list #f #f #f)))) null)) @@ -1533,6 +1593,11 @@ (let ([p (send c get-selection)]) (when p (send c set-string p "New Name") + (for ([in-list (cdr columns)] + [col (in-naturals 1)]) + (send c set-string p + (format "new ~a" col) + col)) (set! actual-content (let loop ([ac actual-content][p p]) (if (zero? p) @@ -2300,12 +2365,39 @@ (make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f))) (make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t))) (make-object button% "Make Combo Frame" cp (lambda (b e) (combo-frame #f))) +(define lcp (make-object horizontal-pane% ap)) +(send lcp stretchable-width #f) +(define list-columns-choice (new choice% + [parent lcp] + [label "List Type"] + [choices '("Single Column" + "Multiple Columns")])) +(define (get-columns) (if (zero? (send list-columns-choice get-selection)) + '("Column") + '("Main Entry" "Extra" "Final"))) +(define list-headers-choice (new check-box% + [parent lcp] + [label "Show Columns"])) +(define (get-headers) (if (send list-headers-choice get-value) + '(column-headers clickable-headers reorderable-headers variable-columns) + '())) +(define list-order-choice (new check-box% + [parent lcp] + [label "Swap Last Two"])) +(define (get-order) (if (and (positive? (send list-columns-choice get-selection)) + (send list-order-choice get-value)) + '(0 2 1) + #f)) (define lp (make-object horizontal-pane% ap)) (send lp stretchable-width #f) -(make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f))) -(make-object button% "Make Empty List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #t))) -(make-object button% "Make MultiList Frame" lp (lambda (b e) (choice-or-list-frame #t '(multiple) #f))) -(make-object button% "Make MultiExtendList Frame" lp (lambda (b e) (choice-or-list-frame #t '(extended) #f))) +(make-object button% "Make List Frame" lp + (lambda (b e) (choice-or-list-frame #t '(single) #f (get-columns) (get-headers) (get-order)))) +(make-object button% "Make Empty List Frame" lp + (lambda (b e) (choice-or-list-frame #t '(single) #t (get-columns) (get-headers) (get-order)))) +(make-object button% "Make MultiList Frame" lp + (lambda (b e) (choice-or-list-frame #t '(multiple) #f (get-columns) (get-headers) (get-order)))) +(make-object button% "Make MultiExtendList Frame" lp + (lambda (b e) (choice-or-list-frame #t '(extended) #f (get-columns) (get-headers) (get-order)))) (define gsp (make-object horizontal-pane% ap)) (send gsp stretchable-height #f) (make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame)))