1#lang racket/base
2(require ffi/unsafe/objc
3         ffi/unsafe
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         "const.rkt"
12         "window.rkt"
13         "font.rkt"
14         "../common/event.rkt")
15
16(provide
17 (protect-out list-box%))
18
19;; ----------------------------------------
20
21(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet NSFont)
22(import-protocol NSTableViewDataSource)
23
24(define NSLineBreakByTruncatingTail 4)
25
26(define during-selection-set? (make-parameter #f))
27
28;; 11.0 and up:
29(define NSTableViewStyleAutomatic 0)
30(define NSTableViewStyleFullWidth 1)
31(define NSTableViewStyleInset 2)
32(define NSTableViewStyleSourceList 3)
33(define NSTableViewStylePlain 4)
34
35(define default-cell-font
36  (and (version-11.0-or-later?)
37       (atomically
38        (let ([f (tell NSFont controlContentFontOfSize: #:type _CGFloat 0.0)])
39          (tellv f retain)
40          f))))
41
42(define-objc-class RacketTableView NSTableView
43  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
44  [wxb]
45  [-a _void (doubleClicked: [_id sender])
46      (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))]
47  [-a _void (tableViewSelectionDidChange: [_id aNotification])
48      (unless (during-selection-set?)
49        (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box))))]
50  [-a _void (tableView: [_id view] didClickTableColumn: [_id col])
51      (queue-window*-event wxb (lambda (wx) (send wx clicked-column col)))]
52  [-a _void (tableViewColumnDidMove: [_id view])
53      (let ([wx (->wx wxb)])
54        (when wx (send wx reset-column-order)))])
55
56(define-objc-class RacketDataSource NSObject
57  #:protocols (NSTableViewDataSource)
58  [wxb]
59  [-a _NSInteger (numberOfRowsInTableView: [_id view])
60      (let ([wx (->wx wxb)])
61        (send wx number))]
62  [-a _id (tableView: [_id aTableView]
63                      objectValueForTableColumn: [_id aTableColumn]
64                      row: [_NSInteger rowIndex])
65      (define wx (->wx wxb))
66      (define text (if wx (send wx get-cell aTableColumn rowIndex) "???"))
67      (define cell (tell (tell NSCell alloc) initTextCell: #:type _NSString text))
68      (define font (and wx (send wx get-cell-font)))
69      (tellv cell setLineBreakMode: #:type _NSUInteger NSLineBreakByTruncatingTail)
70      (when font (tellv cell setFont: font))
71      (tell cell autorelease)])
72
73(define (remove-nth data i)
74  (cond
75   [(zero? i) (cdr data)]
76   [else (cons (car data) (remove-nth (cdr data) (sub1 i)))]))
77
78(defclass list-box% item%
79  (init parent cb
80        label kind x y w h
81        choices style
82        font label-font
83        columns column-order)
84  (inherit set-size init-font
85           register-as-child)
86
87  (define source (as-objc-allocation
88                  (tell (tell RacketDataSource alloc) init)))
89  (set-ivar! source wxb (->wxb this))
90
91  (define itemss (cons choices
92                       (for/list ([i (in-list (cdr columns))])
93                         (for/list ([i choices])
94                           ""))))
95  (define num-columns (length columns))
96  (define data (map (lambda (x) (box #f)) choices))
97  (define count (length choices))
98
99  (define cocoa (as-objc-allocation
100                 (tell (tell NSScrollView alloc) init)))
101  (define-values (content-cocoa column-cocoas)
102    (let ([content-cocoa
103           (as-objc-allocation
104            (tell (tell RacketTableView alloc) init))])
105      (tellv content-cocoa setDelegate: content-cocoa)
106      (tellv content-cocoa setDataSource: source)
107      (define cols
108        (for/list ([title (in-list columns)])
109          (let ([col (as-objc-allocation
110                      (tell (tell NSTableColumn alloc) initWithIdentifier: #:type _NSString title))])
111            (tellv content-cocoa addTableColumn: col)
112            (tellv (tell col headerCell) setStringValue: #:type _NSString title)
113            col)))
114      (init-font content-cocoa font)
115      (when (version-11.0-or-later?)
116        (tellv content-cocoa setStyle: #:type _NSInteger NSTableViewStyleFullWidth)
117        (tellv content-cocoa setIntercellSpacing: #:type _NSSize (make-NSSize 1.0 1.0)))
118      (values content-cocoa cols)))
119  (set-ivar! content-cocoa wxb (->wxb this))
120
121  (tellv cocoa setDocumentView: content-cocoa)
122  (tellv cocoa setHasVerticalScroller: #:type _BOOL #t)
123  (tellv cocoa setHasHorizontalScroller: #:type _BOOL #t)
124  (unless (memq 'column-headers style)
125    (tellv content-cocoa setHeaderView: #f))
126  (define allow-multi? (not (eq? kind 'single)))
127  (when allow-multi?
128    (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t))
129  (unless (memq 'reorderable-headers style)
130    (tellv content-cocoa setAllowsColumnReordering: #:type _BOOL #f))
131
132  (when column-order
133    (set-column-order column-order))
134  (define/public (set-column-order column-order)
135    (atomically
136     (for ([c (in-list column-cocoas)])
137       (tellv c retain)
138       (tellv content-cocoa removeTableColumn: c))
139     (for ([pos (in-list column-order)])
140       (let ([c (list-ref column-cocoas pos)])
141         (tellv content-cocoa addTableColumn: c)
142         (tellv c release)))
143     (reset-column-order)))
144
145  (define/public (set-column-label i s)
146    (let ([col (list-ref column-cocoas i)])
147      (tellv (tell col headerCell) setStringValue: #:type _NSString s)
148      (reset)))
149
150  (define/public (set-column-size i w min-w max-w)
151    (let ([col (list-ref column-cocoas i)])
152      (tellv col setMinWidth: #:type _CGFloat min-w)
153      (tellv col setMaxWidth: #:type _CGFloat max-w)
154      (tellv col setWidth: #:type _CGFloat w)))
155
156  (define/public (get-column-size i)
157    (let ([col (list-ref column-cocoas i)]
158          [int (lambda (v) (inexact->exact (round v)))])
159      (values
160       (int (tell #:type _CGFloat col width))
161       (int (tell #:type _CGFloat col minWidth))
162       (min 10000 (int (tell #:type _CGFloat col maxWidth))))))
163
164  (define/override (get-cocoa-content) content-cocoa)
165  (define/override (get-cocoa-control) content-cocoa)
166
167  (super-new [parent parent]
168             [cocoa cocoa]
169             [no-show? (memq 'deleted style)]
170             [callback cb])
171
172  (set-size 0 0 32 50)
173  ; (tellv content-cocoa sizeToFit)
174
175  (tellv content-cocoa setTarget: content-cocoa)
176  (tellv content-cocoa setDoubleAction: #:type _SEL (selector doubleClicked:))
177
178  (def/public-unimplemented get-label-font)
179
180  (define cell-font (or (and font (font->NSFont font))
181                        default-cell-font))
182  (when cell-font
183    (tellv content-cocoa setRowHeight: #:type _CGFloat
184           (+ (tell #:type _CGFloat cell-font defaultLineHeightForFont) 2)))
185
186  (define/public (get-cell-font)
187    cell-font)
188
189  (define/public (get-selection)
190    (if allow-multi?
191        (let ([l (get-selections)])
192          (if (null? l)
193              -1
194              (car l)))
195        (tell #:type _NSInteger content-cocoa selectedRow)))
196  (define/public (get-selections)
197    (atomically
198     (with-autorelease
199      (let ([v (tell content-cocoa selectedRowIndexes)])
200        (begin0
201         (let loop ([i (tell #:type _NSInteger v firstIndex)])
202           (cond
203            [(= i NSNotFound) null]
204            [else (cons i (loop (tell #:type _NSInteger v
205                                      indexGreaterThanIndex: #:type _NSInteger i)))])))))))
206
207  (define/private (header-height)
208    (let ([hv (tell content-cocoa headerView)])
209      (if hv
210          (NSSize-height (NSRect-size (tell #:type _NSRect hv frame)))
211          0)))
212
213  (define/public (number-of-visible-items)
214    (define doc (tell #:type _NSRect cocoa documentVisibleRect))
215    (define h (+ (tell #:type _CGFloat content-cocoa rowHeight)
216                 (NSSize-height (tell #:type _NSSize content-cocoa intercellSpacing))))
217    (define doc-h (- (NSSize-height (NSRect-size doc))
218                     (header-height)))
219    (define n (floor (/ doc-h h)))
220    (if (rational? n)
221        (max 1 (inexact->exact n))
222        1))
223  (define/public (get-first-item)
224    (define doc (tell #:type _NSRect cocoa documentVisibleRect))
225    (define h (header-height))
226    (NSRange-location (tell #:type _NSRange content-cocoa
227                            rowsInRect: #:type _NSRect
228                            (if (zero? h)
229                                doc
230                                (make-NSRect (NSRect-origin doc)
231                                             (make-NSSize (NSSize-width (NSRect-size doc))
232                                                          (- (NSSize-height (NSRect-size doc)) h)))))))
233
234  (define/public (set-first-visible-item i)
235    (define num-vis (number-of-visible-items))
236    (define start (max 0 (min i (- count num-vis))))
237    (tellv content-cocoa scrollRowToVisible: #:type _NSInteger start)
238    (tellv content-cocoa scrollRowToVisible: #:type _NSInteger (+ start (sub1 num-vis))))
239
240  (define/private (replace items i s)
241    (append (take items i)
242            (list s)
243            (drop items (add1 i))))
244
245  (define/public (set-string i s [col 0])
246    (let ([new-itemss (replace
247                       itemss
248                       col
249                       (replace (list-ref itemss col)
250                                i
251                                s))])
252      (set! itemss new-itemss))
253    (reset))
254
255  (define/public (number)
256    ;; Can be called by event-handling thread
257    count)
258  (define/public (get-cell col n)
259    ;; Can be called by event-handling thread
260    (let ([col (if (number? col)
261                   (order->number col)
262                   (col->number col))])
263      (if (col . > . num-columns) ; can happen as column is deleted
264          ""
265          (list-ref (list-ref itemss col) n))))
266
267  (define/private (col->number col)
268    (let loop ([l column-cocoas] [pos 0])
269      (cond
270       [(null? l) #f]
271       [(ptr-equal? (car l) col) pos]
272       [else (loop (cdr l) (add1 pos))])))
273
274  ;; When columns are rearranged, we have to be able to map
275  ;; from current column numbers to original column numbers
276  (define order-vector #f)
277  (define/private (order->number col)
278    (prep-order-vector)
279    (vector-ref order-vector col))
280  (define/private (prep-order-vector)
281    (unless order-vector
282      (let ([vec (make-vector (length column-cocoas))])
283        (let ([array (tell content-cocoa tableColumns)])
284          (for/list ([i (in-range (tell #:type _NSUInteger array count))])
285            (let ([col (tell array objectAtIndex: #:type _NSUInteger i)])
286              (vector-set! vec i (col->number col)))))
287        (set! order-vector vec))))
288  (define/public (reset-column-order)
289    (set! order-vector #f))
290
291  (define/public (get-column-order)
292    (prep-order-vector)
293    (vector->list order-vector))
294
295  (define/public (append-column title)
296    (atomically
297     (let ([col (as-objc-allocation
298                 (tell (tell NSTableColumn alloc) initWithIdentifier: #:type _NSString title))])
299       (tellv content-cocoa addTableColumn: col)
300       (tellv (tell col headerCell) setStringValue: #:type _NSString title)
301       (set! column-cocoas (append column-cocoas (list col)))
302       (set! itemss (append itemss
303                            (list (for/list ([i (in-list (car itemss))])
304                                    ""))))
305       (set! num-columns (add1 num-columns))
306       (reset-column-order)))
307    (reset))
308
309  (define/public (delete-column i)
310    (atomically
311     (let ([c (list-ref column-cocoas i)])
312       (define (drop-nth l i)
313         (cond
314          [(zero? i) (cdr l)]
315          [else (cons (car l) (drop-nth (cdr l) (sub1 i)))]))
316       (set! num-columns (sub1 num-columns))
317       (tellv content-cocoa removeTableColumn: c)
318       (set! column-cocoas (drop-nth column-cocoas i))
319       (set! itemss (drop-nth itemss i))
320       (reset-column-order)))
321    (reset))
322
323  (define callback cb)
324  (define/public (clicked event-type)
325    (unless (zero? count)
326      (callback this (new control-event%
327                          [event-type event-type]
328                          [time-stamp (current-milliseconds)]))))
329
330  (define can-click-column? (memq 'clickable-headers style))
331  (define/public (clicked-column col)
332    (when can-click-column?
333      (let ([pos (col->number col)])
334        (callback this (new column-control-event%
335                            [event-type 'list-box-column]
336                            [time-stamp (current-milliseconds)]
337                            [column pos])))))
338
339  (define/public (set-data i v) (set-box! (list-ref data i) v))
340  (define/public (get-data i) (unbox (list-ref data i)))
341
342  (define/public (selected? i)
343    (tell #:type _BOOL content-cocoa isRowSelected: #:type _NSInteger i))
344
345  (define/public (select i [on? #t] [extend? #t])
346    (parameterize ([during-selection-set? #t])
347      (if on?
348          (atomically
349           (with-autorelease
350             (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
351               (tellv content-cocoa
352                      selectRowIndexes: index
353                      byExtendingSelection: #:type _BOOL (and extend? allow-multi?)))))
354          (tellv content-cocoa deselectRow: #:type _NSInteger i))))
355  (define/public (set-selection i)
356    (select i #t #f))
357
358  (define/public (delete i)
359    (atomically
360     (set! count (sub1 count))
361     (set! itemss (for/list ([items (in-list itemss)])
362                    (remove-nth items i)))
363     (set! data (remove-nth data i)))
364    (reset))
365  (define/public (clear)
366    (atomically
367     (set! count 0)
368     (set! itemss (for/list ([items (in-list itemss)])
369                    null))
370     (set! data null))
371    (reset))
372  (define/public (set choices . more-choices)
373    (atomically
374     (set! itemss (cons choices more-choices))
375     (set! data (map (lambda (x) (box #f)) choices))
376     (set! count (length choices)))
377    (reset))
378
379  (public [append* append])
380  (define (append* s [v #f])
381    (atomically
382     (set! count (add1 count))
383     (set! itemss (cons (append (car itemss) (list s))
384                        (for/list ([items (in-list (cdr itemss))])
385                          (append items (list "")))))
386     (set! data (append data (list (box v)))))
387    (reset))
388
389  (define/public (reset)
390    (tellv content-cocoa noteNumberOfRowsChanged)
391    (tellv content-cocoa reloadData))
392
393  (define/override (maybe-register-as-child parent on?)
394    (register-as-child parent on?)))
395