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