381 lines
14 KiB
Racket
381 lines
14 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
racket/class
|
|
(only-in racket/list take drop)
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"font.rkt"
|
|
"../common/event.rkt")
|
|
|
|
(provide
|
|
(protect-out list-box%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet)
|
|
(import-protocol NSTableViewDataSource)
|
|
|
|
(define NSLineBreakByTruncatingTail 4)
|
|
|
|
(define-objc-class RacketTableView NSTableView
|
|
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
|
|
[wxb]
|
|
[-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
|
|
(let ([wx (->wx wxb)])
|
|
(tell
|
|
(let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString
|
|
(if wx (send wx get-cell column row) "???"))]
|
|
[font (and wx (send wx get-cell-font))])
|
|
(tellv c setLineBreakMode: #:type _NSUInteger NSLineBreakByTruncatingTail)
|
|
(when font
|
|
(tellv c setFont: font))
|
|
c)
|
|
autorelease))]
|
|
[-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)))]
|
|
[-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 RacketDataSource NSObject
|
|
#:protocols (NSTableViewDataSource)
|
|
[wxb]
|
|
[-a _NSInteger (numberOfRowsInTableView: [_id view])
|
|
(let ([wx (->wx wxb)])
|
|
(send wx number))]
|
|
[-a _NSString (tableView: [_id aTableView]
|
|
objectValueForTableColumn: [_id aTableColumn]
|
|
row: [_NSInteger rowIndex])
|
|
(let ([wx (->wx wxb)])
|
|
(if wx
|
|
(send wx get-cell aTableColumn rowIndex)
|
|
"???"))])
|
|
|
|
(define (remove-nth data i)
|
|
(cond
|
|
[(zero? i) (cdr data)]
|
|
[else (cons (car data) (remove-nth (cdr data) (sub1 i)))]))
|
|
|
|
(defclass list-box% item%
|
|
(init parent cb
|
|
label kind x y w h
|
|
choices style
|
|
font label-font
|
|
columns column-order)
|
|
(inherit set-size init-font
|
|
register-as-child)
|
|
|
|
(define source (as-objc-allocation
|
|
(tell (tell RacketDataSource alloc) init)))
|
|
(set-ivar! source wxb (->wxb this))
|
|
|
|
(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-values (content-cocoa column-cocoas)
|
|
(let ([content-cocoa
|
|
(as-objc-allocation
|
|
(tell (tell RacketTableView 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: #:type _NSString title))])
|
|
(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 cocoa setHasHorizontalScroller: #:type _BOOL #t)
|
|
(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))
|
|
(min 10000 (int (tell #:type _CGFloat col maxWidth))))))
|
|
|
|
(define/override (get-cocoa-content) content-cocoa)
|
|
(define/override (get-cocoa-control) content-cocoa)
|
|
|
|
(super-new [parent parent]
|
|
[cocoa cocoa]
|
|
[no-show? (memq 'deleted style)]
|
|
[callback cb])
|
|
|
|
(set-size 0 0 32 50)
|
|
; (tellv content-cocoa sizeToFit)
|
|
|
|
(tellv content-cocoa setTarget: content-cocoa)
|
|
(tellv content-cocoa setDoubleAction: #:type _SEL (selector doubleClicked:))
|
|
|
|
(def/public-unimplemented get-label-font)
|
|
|
|
(define cell-font (and font (font->NSFont font)))
|
|
(when cell-font
|
|
(tellv content-cocoa setRowHeight: #:type _CGFloat
|
|
(+ (tell #:type _CGFloat cell-font defaultLineHeightForFont) 2)))
|
|
|
|
(define/public (get-cell-font)
|
|
cell-font)
|
|
|
|
(define/public (get-selection)
|
|
(if allow-multi?
|
|
(let ([l (get-selections)])
|
|
(if (null? l)
|
|
-1
|
|
(car l)))
|
|
(tell #:type _NSInteger content-cocoa selectedRow)))
|
|
(define/public (get-selections)
|
|
(atomically
|
|
(with-autorelease
|
|
(let ([v (tell content-cocoa selectedRowIndexes)])
|
|
(begin0
|
|
(let loop ([i (tell #:type _NSInteger v firstIndex)])
|
|
(cond
|
|
[(= i NSNotFound) null]
|
|
[else (cons i (loop (tell #:type _NSInteger v
|
|
indexGreaterThanIndex: #:type _NSInteger i)))])))))))
|
|
|
|
(define/private (header-height)
|
|
(let ([hv (tell content-cocoa headerView)])
|
|
(if hv
|
|
(NSSize-height (NSRect-size (tell #:type _NSRect hv frame)))
|
|
0)))
|
|
|
|
(define/public (number-of-visible-items)
|
|
(define doc (tell #:type _NSRect cocoa documentVisibleRect))
|
|
(define h (+ (tell #:type _CGFloat content-cocoa rowHeight)
|
|
(NSSize-height (tell #:type _NSSize content-cocoa intercellSpacing))))
|
|
(define doc-h (- (NSSize-height (NSRect-size doc))
|
|
(header-height)))
|
|
(define n (floor (/ doc-h h)))
|
|
(if (rational? n)
|
|
(max 1 (inexact->exact n))
|
|
1))
|
|
(define/public (get-first-item)
|
|
(define doc (tell #:type _NSRect cocoa documentVisibleRect))
|
|
(define h (header-height))
|
|
(NSRange-location (tell #:type _NSRange content-cocoa
|
|
rowsInRect: #:type _NSRect
|
|
(if (zero? h)
|
|
doc
|
|
(make-NSRect (NSRect-origin doc)
|
|
(make-NSSize (NSSize-width (NSRect-size doc))
|
|
(- (NSSize-height (NSRect-size doc)) h)))))))
|
|
|
|
(define/public (set-first-visible-item i)
|
|
(define num-vis (number-of-visible-items))
|
|
(define start (max 0 (min i (- count num-vis))))
|
|
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger start)
|
|
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger (+ start (sub1 num-vis))))
|
|
|
|
(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-cell col n)
|
|
;; Can be called by event-handling thread
|
|
(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: #:type _NSString title))])
|
|
(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-column-order)))
|
|
(reset))
|
|
|
|
(define callback cb)
|
|
(define/public (clicked event-type)
|
|
(unless (zero? count)
|
|
(callback this (new control-event%
|
|
[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)))
|
|
|
|
(define/public (selected? i)
|
|
(tell #:type _BOOL content-cocoa isRowSelected: #:type _NSInteger i))
|
|
|
|
(define/public (select i [on? #t] [extend? #t])
|
|
(if on?
|
|
(atomically
|
|
(with-autorelease
|
|
(let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
|
|
(tellv content-cocoa
|
|
selectRowIndexes: index
|
|
byExtendingSelection: #:type _BOOL (and extend? allow-multi?)))))
|
|
(tellv content-cocoa deselectRow: #:type _NSInteger i)))
|
|
(define/public (set-selection i)
|
|
(select i #t #f))
|
|
|
|
(define/public (delete 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)
|
|
(atomically
|
|
(set! count 0)
|
|
(set! itemss (for/list ([items (in-list itemss)])
|
|
null))
|
|
(set! data null))
|
|
(reset))
|
|
(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])
|
|
(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)
|
|
(tellv content-cocoa noteNumberOfRowsChanged)
|
|
(tellv content-cocoa reloadData))
|
|
|
|
(define/override (maybe-register-as-child parent on?)
|
|
(register-as-child parent on?)))
|