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