1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 racket/class 5 (only-in racket/list take drop) 6 "../../syntax.rkt" 7 "../../lock.rkt" 8 "item.rkt" 9 "utils.rkt" 10 "types.rkt" 11 "window.rkt" 12 "const.rkt" 13 "panel.rkt" 14 "../common/event.rkt") 15 16(provide 17 (protect-out list-box%)) 18 19;; ---------------------------------------- 20 21(define-cstruct _GtkTreeIter ([stamp _int] 22 [user_data _pointer] 23 [user_data2 _pointer] 24 [user_data3 _pointer])) 25 26(define _GtkListStore (_cpointer 'GtkListStore)) 27(define _GtkCellRenderer (_cpointer 'GtkCellRenderer)) 28(define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn) 29 30(define GTK_SELECTION_SINGLE 1) 31(define GTK_SELECTION_MULTIPLE 3) 32 33(define GTK_TREE_VIEW_COLUMN_AUTOSIZE 1) 34(define GTK_TREE_VIEW_COLUMN_FIXED 2) 35 36(define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) 37(define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) 38 39(define-gtk gtk_list_store_newv (_fun _int (_list i _long) -> _GtkListStore)) 40(define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void)) 41(define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) 42(define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) 43(define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) 44(define-gtk gtk_tree_view_set_model (_fun _GtkWidget _GtkListStore -> _void)) 45(define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void)) 46(define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer)) 47(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) 48(define-gtk gtk_tree_view_column_set_attributes (_fun _GtkTreeViewColumn _GtkCellRenderer _string _int _pointer -> _void)) 49(define-gtk gtk_tree_view_column_set_resizable (_fun _GtkTreeViewColumn _gboolean -> _void)) 50(define-gtk gtk_tree_view_column_set_clickable (_fun _GtkTreeViewColumn _gboolean -> _void)) 51(define-gtk gtk_tree_view_column_set_reorderable (_fun _GtkTreeViewColumn _gboolean -> _void)) 52(define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) 53(define-gtk gtk_tree_view_remove_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) 54(define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) 55(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void)) 56(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) 57(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) 58(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) 59(define-gtk gtk_tree_view_get_column (_fun _GtkWidget _int -> _GtkTreeViewColumn)) 60(define-gtk gtk_tree_view_move_column_after (_fun _GtkWidget _GtkTreeViewColumn (_or-null _GtkTreeViewColumn) -> _void)) 61(define-gtk gtk_tree_view_column_set_title (_fun _GtkTreeViewColumn _string -> _void)) 62(define-gtk gtk_tree_view_column_set_sizing (_fun _GtkTreeViewColumn _int -> _void)) 63(define-gtk gtk_tree_view_column_get_width (_fun _GtkTreeViewColumn -> _int)) 64(define-gtk gtk_tree_view_column_get_min_width (_fun _GtkTreeViewColumn -> _int)) 65(define-gtk gtk_tree_view_column_get_max_width (_fun _GtkTreeViewColumn -> _int)) 66(define-gtk gtk_tree_view_column_set_fixed_width (_fun _GtkTreeViewColumn _int -> _void)) 67(define-gtk gtk_tree_view_column_set_min_width (_fun _GtkTreeViewColumn _int -> _void)) 68(define-gtk gtk_tree_view_column_set_max_width (_fun _GtkTreeViewColumn _int -> _void)) 69 70(define _GList (_cpointer 'List)) 71(define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) 72(define-glib g_list_free (_fun _GList -> _void)) 73(define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) 74(define-gtk gtk_tree_selection_path_is_selected (_fun _GtkWidget _pointer -> _gboolean)) 75(define-gtk gtk_tree_selection_unselect_all (_fun _GtkWidget -> _void)) 76(define-gtk gtk_tree_selection_select_path (_fun _GtkWidget _pointer -> _void)) 77(define-gtk gtk_tree_selection_unselect_path (_fun _GtkWidget _pointer -> _void)) 78(define-gtk gtk_tree_path_new_from_indices (_fun _int _int -> _pointer)) 79(define-gtk gtk_tree_path_free (_fun _pointer -> _void)) 80(define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) 81 82(define-gtk gtk_tree_view_get_visible_range (_fun _GtkWidget [sp : (_ptr o _pointer)] [ep : (_ptr o _pointer)] 83 -> [ok? : _gboolean] 84 -> (values (if ok? sp #f) (if ok? ep #f)))) 85 86(define-signal-handler connect-changed "changed" 87 (_fun _GtkWidget -> _void) 88 (lambda (gtk) 89 (let ([wx (gtk->wx gtk)]) 90 (when wx 91 (send wx queue-changed))))) 92 93(define-signal-handler connect-clicked "clicked" 94 (_fun _GtkWidget -> _void) 95 (lambda (gtk) 96 (let ([wx (gtk->wx gtk)]) 97 (when wx 98 (send wx column-clicked gtk))))) 99 100(define-signal-handler connect-activated "row-activated" 101 (_fun _GtkWidget _pointer _pointer -> _void) 102 (lambda (gtk path column) 103 (let ([wx (gtk->wx gtk)]) 104 (when wx 105 (send wx queue-activated))))) 106 107(defclass list-box% item% 108 (init parent cb 109 label kind x y w h 110 choices style 111 font label-font 112 columns 113 column-order) 114 (inherit get-gtk set-auto-size is-window-enabled?) 115 116 (define empty-columns (for/list ([l (in-list (cdr columns))]) 117 "")) 118 (define itemss (for/list ([i (in-list choices)]) 119 (cons i empty-columns))) 120 121 (define data (map (lambda (c) (box #f)) choices)) 122 123 124 (define (make-store count) 125 (as-gobject-allocation 126 (gtk_list_store_newv count 127 (for/list ([i (in-range count)]) 128 G_TYPE_STRING)))) 129 (define store (make-store (length columns))) 130 131 (define (reset-content) 132 (let ([iter (make-GtkTreeIter 0 #f #f #f)]) 133 (for ([items (in-list itemss)]) 134 (gtk_list_store_append store iter #f) 135 (for ([item (in-list items)] 136 [col (in-naturals 0)]) 137 (gtk_list_store_set store iter col item -1)))) 138 (maybe-init-select)) 139 140 (define/private (maybe-init-select) 141 ;; For consistency with other platforms, 142 ;; don't try to select an item initially. 143 (when #f 144 (when (and (= (get-selection) -1) 145 (pair? data)) 146 (set-selection 0)))) 147 148 (define-values (gtk scrolled-gtk) 149 (cond 150 [gtk3? 151 ;; See `panel%` for information on why an extra 152 ;; event-box layer is needed here. 153 (define gtk (as-gtk-allocation (gtk_event_box_new))) 154 (define scrolled-gtk (gtk_scrolled_window_new #f #f)) 155 (gtk_container_add gtk scrolled-gtk) 156 (gtk_widget_show scrolled-gtk) 157 (values gtk scrolled-gtk)] 158 [else 159 (define scrolled-gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f))) 160 (values scrolled-gtk scrolled-gtk)])) 161 (gtk_scrolled_window_set_policy scrolled-gtk GTK_POLICY_AUTOMATIC GTK_POLICY_ALWAYS) 162 163 (define headers? (memq 'column-headers style)) 164 (define click-headers? (and headers? 165 (memq 'clickable-headers style))) 166 (define reorder-headers? (and headers? 167 (memq 'reorderable-headers style))) 168 169 (define renderer (gtk_cell_renderer_text_new)) 170 171 (define/private (make-column label col) 172 (let* ([column 173 (gtk_tree_view_column_new_with_attributes 174 label 175 renderer 176 "text" 177 col 178 #f)]) 179 (when headers? 180 (gtk_tree_view_column_set_resizable column #t) 181 (gtk_tree_view_column_set_min_width column 1) 182 (when click-headers? 183 (gtk_tree_view_column_set_clickable column #t)) 184 (when reorder-headers? 185 (gtk_tree_view_column_set_reorderable column #t))) 186 column)) 187 188 (define-values (client-gtk column-gtks) 189 (atomically 190 (let* ([client-gtk (gtk_tree_view_new_with_model store)] 191 [columns (for/list ([label (in-list columns)] 192 [col (in-naturals)]) 193 (make-column label col))]) 194 (gobject-unref store) 195 (unless headers? 196 (gtk_tree_view_set_headers_visible client-gtk #f)) 197 (for ([column (in-list columns)]) 198 (gtk_tree_view_append_column client-gtk column)) 199 (values client-gtk columns)))) 200 201 (when column-order 202 (set-column-order column-order)) 203 (define/public (set-column-order column-order) 204 (let loop ([prev #f] [l column-order]) 205 (unless (null? l) 206 (let ([column-gtk (list-ref column-gtks (car l))]) 207 (gtk_tree_view_move_column_after client-gtk column-gtk prev) 208 (loop column-gtk (cdr l)))))) 209 210 (gtk_container_add scrolled-gtk client-gtk) 211 (gtk_widget_show client-gtk) 212 213 (define selection 214 (gtk_tree_view_get_selection client-gtk)) 215 216 (gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended) 217 (eq? kind 'multiple)) 218 GTK_SELECTION_MULTIPLE 219 GTK_SELECTION_SINGLE)) 220 221 (super-new [parent parent] 222 [gtk gtk] 223 [extra-gtks (list* client-gtk selection 224 (if (memq 'clickable-headers style) 225 column-gtks 226 null))] 227 [callback cb] 228 [font font] 229 [no-show? (memq 'deleted style)]) 230 231 (set-auto-size 32) ; 32 is extra width 232 233 (connect-changed selection) 234 (connect-activated client-gtk) 235 (for ([column (in-list column-gtks)]) 236 (column-finish column)) 237 238 (define/private (column-finish column) 239 (connect-clicked column) 240 (let ([w (gtk_tree_view_column_get_width column)]) 241 (gtk_tree_view_column_set_sizing column GTK_TREE_VIEW_COLUMN_FIXED) 242 (gtk_tree_view_column_set_fixed_width column (max 50 w)))) 243 244 (define/override (get-client-gtk) client-gtk) 245 246 (define callback cb) 247 (define ignore-click? #f) 248 (define/private (do-queue-changed type) 249 ;; Called from event-handling thread 250 (unless ignore-click? 251 (queue-window-event 252 this 253 (lambda () 254 (unless (null? itemss) 255 (callback this (new control-event% 256 [event-type type] 257 [time-stamp (current-milliseconds)]))))))) 258 259 (define/public (queue-changed) 260 (do-queue-changed 'list-box)) 261 262 (define/public (queue-activated) 263 (do-queue-changed 'list-box-dclick)) 264 265 (define/private (column->pos col) 266 (let loop ([l column-gtks] 267 [pos 0]) 268 (cond 269 [(null? l) #f] 270 [(ptr-equal? (car l) col) pos] 271 [else (loop (cdr l) (add1 pos))]))) 272 273 (define/public (column-clicked col) 274 (let ([pos (column->pos col)]) 275 (when pos 276 (queue-window-event 277 this 278 (lambda () 279 (callback this (new column-control-event% 280 [event-type 'list-box-column] 281 [column pos] 282 [time-stamp (current-milliseconds)]))))))) 283 284 (define/public (get-column-order) 285 (for/list ([i (in-range (length column-gtks))]) 286 (column->pos (gtk_tree_view_get_column client-gtk i)))) 287 288 (define/private (get-iter i) 289 (atomically 290 (let ([iter (make-GtkTreeIter 0 #f #f #f)] 291 [p (gtk_tree_path_new_from_indices i -1)]) 292 (gtk_tree_model_get_iter store iter p) 293 (gtk_tree_path_free p) 294 iter))) 295 296 (def/public-unimplemented get-label-font) 297 298 (define/private (replace-nth items i s) 299 (append (take items i) 300 (list s) 301 (drop items (add1 i)))) 302 303 (define/public (set-string i s [col 0]) 304 (set! itemss 305 (replace-nth itemss 306 i 307 (replace-nth (list-ref itemss i) 308 col 309 s))) 310 (gtk_list_store_set store (get-iter i) col s -1)) 311 312 (define/public (set-column-label i s) 313 (gtk_tree_view_column_set_title (list-ref column-gtks i) s)) 314 315 (define/public (set-column-size i w mn mx) 316 (let ([col (list-ref column-gtks i)]) 317 (gtk_tree_view_column_set_min_width col mn) 318 (gtk_tree_view_column_set_max_width col mx) 319 (gtk_tree_view_column_set_fixed_width col w))) 320 321 (define/public (get-column-size i) 322 (let ([col (list-ref column-gtks i)]) 323 (values 324 (gtk_tree_view_column_get_width col) 325 (max (gtk_tree_view_column_get_min_width col) 0) 326 (let ([v (gtk_tree_view_column_get_max_width col)]) 327 (if (negative? v) 328 10000 329 v))))) 330 331 (define/public (set-first-visible-item i) 332 (atomically 333 (let ([p (gtk_tree_path_new_from_indices i -1)]) 334 (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) 335 (gtk_tree_path_free p)))) 336 337 (define/public (set choices . more-choices) 338 (atomically 339 (set! ignore-click? #t) 340 (clear) 341 (set! itemss (apply map 342 (lambda (i . rest) 343 (cons i rest)) 344 choices 345 more-choices)) 346 (set! data (map (lambda (x) (box #f)) choices)) 347 (reset-content) 348 (set! ignore-click? #f))) 349 350 (define/public (get-selections) 351 (atomically 352 (let ([list (gtk_tree_selection_get_selected_rows selection #f)]) 353 (if list 354 (let ([v null]) 355 (g_list_foreach list 356 (lambda (t) 357 (set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int) 358 v))) 359 #f) 360 (g_list_foreach list gtk_tree_path_free #f) 361 (g_list_free list) 362 (reverse v)) 363 null)))) 364 (define/public (get-selection) 365 (let ([l (get-selections)]) 366 (if (null? l) 367 -1 368 (car l)))) 369 370 (define/private (get-visible-range) 371 (atomically 372 (let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)]) 373 (begin0 374 (values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0) 375 (if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0)) 376 (when sp (gtk_tree_path_free sp)) 377 (when ep (gtk_tree_path_free ep)))))) 378 379 (define/public (get-first-item) 380 (let-values ([(start end) (get-visible-range)]) 381 start)) 382 (define/public (number-of-visible-items) 383 (let-values ([(start end) (get-visible-range)]) 384 (add1 (- end start)))) 385 386 (define/public (number) (length itemss)) 387 388 (define/public (set-data i v) (set-box! (list-ref data i) v)) 389 (define/public (get-data i) (unbox (list-ref data i))) 390 391 (define/public (selected? i) 392 (atomically 393 (let ([p (gtk_tree_path_new_from_indices i -1)]) 394 (begin0 395 (gtk_tree_selection_path_is_selected selection p) 396 (gtk_tree_path_free p))))) 397 398 (define/public (select i [on? #t] [extend? #t]) 399 (atomically 400 (set! ignore-click? #t) 401 (let ([p (gtk_tree_path_new_from_indices i -1)]) 402 (if on? 403 (begin 404 (unless extend? 405 (gtk_tree_selection_unselect_all selection)) 406 (gtk_tree_selection_select_path selection p)) 407 (gtk_tree_selection_unselect_path selection p)) 408 (gtk_tree_path_free p)) 409 (set! ignore-click? #f))) 410 411 (define/public (set-selection i) 412 (select i #t #f)) 413 414 (define/public (delete i) 415 (set! itemss (append (take itemss i) (drop itemss (add1 i)))) 416 (set! data (append (take data i) (drop data (add1 i)))) 417 (gtk_list_store_remove store (get-iter i)) 418 (void)) 419 420 (define/public (clear) 421 (set! itemss null) 422 (set! data null) 423 (gtk_list_store_clear store)) 424 425 (public [append* append]) 426 (define (append* s [v #f]) 427 (atomically 428 (set! ignore-click? #t) 429 (set! itemss (append itemss 430 (list (cons s empty-columns)))) 431 (set! data (append data (list (box v)))) 432 (let ([iter (make-GtkTreeIter 0 #f #f #f)]) 433 (gtk_list_store_append store iter #f) 434 (gtk_list_store_set store iter 0 s -1)) 435 (maybe-init-select) 436 (set! ignore-click? #f))) 437 438 (define/public (append-column label) 439 (let ([col (add1 (length empty-columns))]) 440 (set! store (make-store (add1 col))) 441 (set! empty-columns (cons "" empty-columns)) 442 (set! itemss 443 (for/list ([items (in-list itemss)]) 444 (append items (list "")))) 445 (gtk_tree_view_set_model client-gtk store) 446 (let ([renderer (gtk_cell_renderer_text_new)]) 447 (gtk_tree_view_column_new_with_attributes 448 label 449 renderer 450 "text" 451 col 452 #f)) 453 (let ([column-gtk (make-column label col)]) 454 (g_object_set_data column-gtk "wx" (g_object_get_data client-gtk "wx")) 455 (set! column-gtks (append column-gtks (list column-gtk))) 456 (gtk_tree_view_append_column client-gtk column-gtk) 457 (reset-content) 458 (column-finish column-gtk)))) 459 460 (define/public (delete-column i) 461 (define (remove-nth l i) 462 (cond 463 [(zero? i) (cdr l)] 464 [else (cons (car l) (remove-nth (cdr l) (sub1 i)))])) 465 (set! empty-columns (cdr empty-columns)) 466 (set! itemss 467 (for/list ([items (in-list itemss)]) 468 (remove-nth items i))) 469 (let ([old (list-ref column-gtks i)]) 470 (set! column-gtks (remove-nth column-gtks i)) 471 (gtk_tree_view_remove_column client-gtk old)) 472 (for ([column-gtk (in-list column-gtks)] 473 [pos (in-naturals)]) 474 (when (pos . >= . i) 475 (gtk_tree_view_column_set_attributes column-gtk 476 renderer 477 "text" 478 pos 479 #f))) 480 (gtk_list_store_clear store) 481 (reset-content)) 482 483 (atomically (reset-content))) 484