545 lines
20 KiB
Racket
545 lines
20 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw
|
|
(only-in racket/list take drop)
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/event.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"wndclass.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out list-box%))
|
|
|
|
(define WS_EX_CLIENTEDGE #x00000200)
|
|
|
|
(define LBS_NOTIFY #x0001)
|
|
(define LBS_MULTIPLESEL #x0008)
|
|
(define LBS_HASSTRINGS #x0040)
|
|
(define LBS_MULTICOLUMN #x0200)
|
|
(define LBS_WANTKEYBOARDINPUT #x0400)
|
|
(define LBS_EXTENDEDSEL #x0800)
|
|
(define LBS_DISABLENOSCROLL #x1000)
|
|
|
|
(define LBN_SELCHANGE 1)
|
|
(define LBN_DBLCLK 2)
|
|
|
|
(define LB_ERR -1)
|
|
|
|
(define LB_ADDSTRING #x0180)
|
|
(define LB_RESETCONTENT #x0184)
|
|
(define LB_INSERTSTRING #x0181)
|
|
(define LB_DELETESTRING #x0182)
|
|
(define LB_GETTOPINDEX #x018E)
|
|
(define LB_SETTOPINDEX #x0197)
|
|
(define LB_GETITEMHEIGHT #x01A1)
|
|
(define LB_GETSELCOUNT #x0190)
|
|
(define LB_GETSELITEMS #x0191)
|
|
(define LB_GETCURSEL #x0188)
|
|
(define LB_SETSEL #x0185)
|
|
(define LB_SETCURSEL #x0186)
|
|
(define LB_GETSEL #x0187)
|
|
(define LB_SELITEMRANGE #x019B)
|
|
|
|
(define LVCF_WIDTH #x0002)
|
|
(define LVCF_TEXT #x0004)
|
|
(define LVCF_MINWIDTH #x0040)
|
|
|
|
(define LVS_REPORT #x0001)
|
|
(define LVS_SINGLESEL #x0004)
|
|
(define LVS_NOCOLUMNHEADER #x4000)
|
|
(define LVS_SHOWSELALWAYS #x0008)
|
|
|
|
(define LVS_EX_HEADERDRAGDROP #x00000010)
|
|
(define LVS_EX_FULLROWSELECT #x00000020)
|
|
|
|
(define LVIF_TEXT #x0001)
|
|
(define LVIF_DI_SETITEM #x1000)
|
|
|
|
(define LVM_FIRST #x1000)
|
|
(define LVM_INSERTITEMW (+ LVM_FIRST 77))
|
|
(define LVM_GETSTRINGWIDTHW (+ LVM_FIRST 87))
|
|
(define LVM_INSERTCOLUMNW (+ LVM_FIRST 97))
|
|
(define LVM_DELETECOLUMN (+ LVM_FIRST 28))
|
|
(define LVM_SETCOLUMNW (+ LVM_FIRST 96))
|
|
(define LVM_GETCOLUMNW (+ LVM_FIRST 95))
|
|
(define LVM_SETITEMTEXTW (+ LVM_FIRST 116))
|
|
(define LVM_DELETEALLITEMS (+ LVM_FIRST 9))
|
|
(define LVM_GETTOPINDEX (+ LVM_FIRST 39))
|
|
(define LVM_GETCOUNTPERPAGE (+ LVM_FIRST 40))
|
|
(define LVM_ENSUREVISIBLE (+ LVM_FIRST 19))
|
|
(define LVM_DELETEITEM (+ LVM_FIRST 8))
|
|
(define LVM_GETSELECTEDCOUNT (+ LVM_FIRST 50))
|
|
(define LVM_GETNEXTITEM (+ LVM_FIRST 12))
|
|
(define LVM_GETITEMSTATE (+ LVM_FIRST 44))
|
|
(define LVM_SETITEMSTATE (+ LVM_FIRST 43))
|
|
(define LVM_SETEXTENDEDLISTVIEWSTYLE (+ LVM_FIRST 54))
|
|
(define LVM_SETCOLUMNORDERARRAY (+ LVM_FIRST 58))
|
|
(define LVM_GETCOLUMNORDERARRAY (+ LVM_FIRST 59))
|
|
|
|
(define LVN_FIRST -100)
|
|
(define LVN_ITEMCHANGED (- LVN_FIRST 1))
|
|
(define LVN_COLUMNCLICK (- LVN_FIRST 8))
|
|
|
|
(define NM_FIRST 0)
|
|
(define NM_DBLCLK (- NM_FIRST 3))
|
|
|
|
(define LVNI_SELECTED #x0002)
|
|
(define LVIS_SELECTED #x0002)
|
|
|
|
(define-cstruct _LVCOLUMN
|
|
([mask _UINT]
|
|
[fmt _int]
|
|
[cx _int]
|
|
[pszText _permanent-string/utf-16]
|
|
[cchTextMax _int]
|
|
[iSubItem _int]
|
|
[iImage _int]
|
|
[iOrder _int]
|
|
[cxMin _int]
|
|
[cxDefault _int]
|
|
[cxIdeal _int]))
|
|
|
|
(define (make-lvcolumn flags label)
|
|
(make-LVCOLUMN flags
|
|
0 0
|
|
label
|
|
0 0 0 0 0 0 0))
|
|
|
|
(define (free-lvcolumn lv)
|
|
(let ([s (LVCOLUMN-pszText lv)])
|
|
(when s (free s))))
|
|
|
|
(define column-desc (cast (malloc (ctype-sizeof _LVCOLUMN) 'raw)
|
|
_pointer
|
|
_LVCOLUMN-pointer))
|
|
(memset column-desc 0 (ctype-sizeof _LVCOLUMN))
|
|
|
|
;; Microsoft docs say to add padding to a ListView
|
|
;; item's width, but it doesn't say how much padding:
|
|
(define COLUMN-PADDING 16)
|
|
|
|
(define-cstruct _LVITEM
|
|
([mask _UINT]
|
|
[iItem _int]
|
|
[iSubItem _int]
|
|
[state _UINT]
|
|
[stateMask _UINT]
|
|
[pszText _permanent-string/utf-16]
|
|
[cchTextMax _int]
|
|
[iImage _int]
|
|
[lParam _LPARAM]
|
|
[iIndent _int]
|
|
[iGroupId _int]
|
|
[cColumns _UINT]
|
|
[puColumns _UINT]
|
|
[piColFmt _int]
|
|
[iGroup _int]))
|
|
|
|
(define (make-lvitem flags pos col label)
|
|
(make-LVITEM flags
|
|
pos col
|
|
0 0 ; state & statemask
|
|
label
|
|
0 0
|
|
0 ; lParam
|
|
0 0 0
|
|
0 0 0))
|
|
|
|
(define (free-lvitem lv)
|
|
(let ([s (LVITEM-pszText lv)])
|
|
(when s (free s))))
|
|
|
|
(define-cstruct _NMLISTVIEW
|
|
([hdr _NMHDR]
|
|
[iItem _int]
|
|
[iSubItem _int]
|
|
;; ....
|
|
))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define list-box%
|
|
(class item%
|
|
(init parent cb
|
|
label kind x y w h
|
|
choices style
|
|
font label-font
|
|
columns column-order)
|
|
|
|
(inherit set-size set-control-font
|
|
get-client-size)
|
|
|
|
(define num-columns (length columns))
|
|
(define single-column? (and (= 1 num-columns)
|
|
(not (memq 'column-headers style))
|
|
(not (memq 'variable-columns style))))
|
|
(define single? (eq? 'single kind))
|
|
|
|
(define hwnd
|
|
(CreateWindowExW/control WS_EX_CLIENTEDGE
|
|
(if single-column?
|
|
"PLTLISTBOX"
|
|
"PLTSysListView32")
|
|
label
|
|
(if single-column?
|
|
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
|
|
WS_VSCROLL
|
|
(if (memq 'hscroll style) WS_HSCROLL 0)
|
|
(cond
|
|
;; Win32 sense of "multiple" and "extended" is backwards
|
|
[(eq? kind 'extended) LBS_MULTIPLESEL]
|
|
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
|
|
[else 0]))
|
|
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
|
|
LVS_REPORT
|
|
(if (memq 'column-headers style)
|
|
0
|
|
LVS_NOCOLUMNHEADER)
|
|
LVS_SHOWSELALWAYS
|
|
WS_VSCROLL
|
|
(if (memq 'hscroll style) WS_HSCROLL 0)
|
|
(cond
|
|
[(eq? kind 'extended) 0]
|
|
[(eq? kind 'multiple) 0]
|
|
[else LVS_SINGLESEL])))
|
|
0 0 0 0
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f))
|
|
|
|
(when single-column?
|
|
(for ([s (in-list choices)])
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s)))
|
|
|
|
(unless single-column?
|
|
(for ([label (in-list columns)]
|
|
[col (in-naturals)])
|
|
(atomically
|
|
(let ([col-desc (make-lvcolumn LVCF_TEXT label)])
|
|
(SendMessageW/ptr hwnd LVM_INSERTCOLUMNW col col-desc)
|
|
(free-lvcolumn col-desc)))
|
|
(let* ([label-width
|
|
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label)]
|
|
[max-width
|
|
(if (zero? col)
|
|
;; size column based on the content:
|
|
(for/fold ([w label-width]) ([s (in-list choices)]
|
|
[i (in-naturals)])
|
|
(atomically
|
|
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
|
|
LVIF_TEXT)
|
|
i
|
|
col
|
|
s)])
|
|
(if (zero? col)
|
|
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
|
|
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
|
|
(free-lvitem lv)))
|
|
(max w
|
|
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 s)))
|
|
;; size column based on the label, only:
|
|
label-width)])
|
|
(let ([col-desc (make-lvcolumn LVCF_WIDTH #f)])
|
|
(set-LVCOLUMN-cx! col-desc (+ max-width COLUMN-PADDING))
|
|
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)))))
|
|
|
|
(unless single-column?
|
|
(SendMessageW hwnd LVM_SETEXTENDEDLISTVIEWSTYLE 0
|
|
(bitwise-ior LVS_EX_FULLROWSELECT
|
|
(if (memq 'reorderable-headers style)
|
|
LVS_EX_HEADERDRAGDROP
|
|
0))))
|
|
|
|
(when column-order
|
|
(set-column-order column-order))
|
|
|
|
(super-new [callback cb]
|
|
[parent parent]
|
|
[hwnd hwnd]
|
|
[style style])
|
|
|
|
(set-control-font font)
|
|
(set-size #f #f 40 60)
|
|
|
|
(define/override (size->screen v) (->screen* v))
|
|
|
|
(define callback cb)
|
|
|
|
(define/override (is-command? cmd)
|
|
(if single-column?
|
|
(or (= cmd LBN_SELCHANGE)
|
|
(= cmd LBN_DBLCLK))
|
|
(or (= cmd LVN_ITEMCHANGED)
|
|
(= cmd NM_DBLCLK)
|
|
(= cmd LVN_COLUMNCLICK))))
|
|
|
|
(define pending-changed (box #f))
|
|
(define/override (do-command cmd control-hwnd)
|
|
;; LVN_ITEMCHANGED notifications, in particular, get
|
|
;; set for each item that changes in a selection change.
|
|
;; Use a box to cancel pending callbacks to collapse the
|
|
;; multiple callbacks into one.
|
|
(set-box! pending-changed #f)
|
|
(let ([b (box #t)]
|
|
[t (if (if single-column?
|
|
(= cmd LBN_SELCHANGE)
|
|
(= cmd LVN_ITEMCHANGED))
|
|
'list-box
|
|
'list-box-dclick)])
|
|
(unless (eq? t 'list-box-dclick)
|
|
(set! pending-changed b))
|
|
(queue-window-event
|
|
this
|
|
(lambda ()
|
|
(when (unbox b)
|
|
(callback this
|
|
(new control-event%
|
|
[event-type t]
|
|
[time-stamp (current-milliseconds)])))))))
|
|
|
|
(define/override (do-command-ex cmd control-hwnd nmhdr)
|
|
(if (and (not single-column?)
|
|
(= cmd LVN_COLUMNCLICK))
|
|
(let ([col (NMLISTVIEW-iSubItem
|
|
(cast nmhdr _pointer _NMLISTVIEW-pointer))])
|
|
(queue-window-event this (lambda ()
|
|
(callback this
|
|
(new column-control-event%
|
|
[column col]
|
|
[event-type 'list-box-column]
|
|
[time-stamp (current-milliseconds)])))))
|
|
(super do-command-ex cmd control-hwnd nmhdr)))
|
|
|
|
(define num (length choices))
|
|
(define/public (number) num)
|
|
|
|
(define data (map (lambda (x) (box #f)) choices))
|
|
(define/public (get-data i) (unbox (list-ref data i)))
|
|
(define/public (set-data i v) (set-box! (list-ref data i) v))
|
|
|
|
(define/public (set-string i str [col 0])
|
|
(atomically
|
|
(if single-column?
|
|
(begin
|
|
(SendMessageW/str hwnd LB_INSERTSTRING i str)
|
|
(SendMessageW hwnd LB_DELETESTRING (add1 i) 0))
|
|
(let ([lv (make-lvitem 0
|
|
0
|
|
col
|
|
str)])
|
|
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv)
|
|
(free-lvitem lv)))
|
|
(void)))
|
|
|
|
|
|
(define/public (set-column-order column-order)
|
|
(unless single-column?
|
|
(let* ([count num-columns]
|
|
[a (malloc _int count)])
|
|
(for ([n (in-list column-order)]
|
|
[i (in-range count)])
|
|
(ptr-set! a _int i n))
|
|
(SendMessageW/ptr hwnd LVM_SETCOLUMNORDERARRAY count a)
|
|
(InvalidateRect hwnd #f #f))))
|
|
|
|
(define/public (get-column-order)
|
|
(if single-column?
|
|
'(0)
|
|
(let* ([count num-columns]
|
|
[a (malloc _int count)])
|
|
(SendMessageW/ptr hwnd LVM_GETCOLUMNORDERARRAY count a)
|
|
(cast a _gcpointer (_list o _int count)))))
|
|
|
|
(define/public (set-column-label col s)
|
|
(unless single-column?
|
|
(atomically
|
|
(let ([col-desc (make-lvcolumn LVCF_TEXT s)])
|
|
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
|
|
(free-lvcolumn col-desc)))))
|
|
|
|
(define min-col-width 0) ; not kept for us by XP
|
|
(define max-col-width 10000)
|
|
(define/public (set-column-size col w mn mx)
|
|
(if single-column?
|
|
(atomically
|
|
(set! min-col-width mn)
|
|
(set! max-col-width mx))
|
|
(atomically
|
|
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
|
|
(set-LVCOLUMN-cx! col-desc (->screen w))
|
|
(set-LVCOLUMN-cxMin! col-desc (->screen mn))
|
|
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
|
|
(set! min-col-width mn)
|
|
(set! max-col-width mx)))))
|
|
|
|
(define/public (get-column-size col)
|
|
(atomically
|
|
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
|
|
(SendMessageW/ptr hwnd LVM_GETCOLUMNW col col-desc)
|
|
(let ([v (->normal (LVCOLUMN-cx col-desc))])
|
|
(values (max v min-col-width) ; in XP, may have been sized too small
|
|
min-col-width
|
|
max-col-width)))))
|
|
|
|
(define/public (append-column label)
|
|
(atomically
|
|
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_TEXT
|
|
LVCF_WIDTH)
|
|
label)])
|
|
(set-LVCOLUMN-cx! col-desc
|
|
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label))
|
|
(SendMessageW/ptr hwnd LVM_INSERTCOLUMNW num-columns col-desc)
|
|
(free-lvcolumn col-desc))
|
|
(set! num-columns (add1 num-columns))))
|
|
|
|
(define/public (delete-column col)
|
|
(atomically
|
|
(SendMessageW hwnd LVM_DELETECOLUMN col 0)
|
|
(set! num-columns (sub1 num-columns))))
|
|
|
|
(define/public (set-first-visible-item i)
|
|
(if single-column?
|
|
(void (SendMessageW hwnd LB_SETTOPINDEX i 0))
|
|
(let ([c (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)])
|
|
(unless (= c i)
|
|
(if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0)
|
|
i)
|
|
(void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0))
|
|
(void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0)))))))
|
|
|
|
(define/public (get-first-item)
|
|
(SendMessageW hwnd (if single-column? LB_GETTOPINDEX LVM_GETTOPINDEX) 0 0))
|
|
|
|
(define/public (number-of-visible-items)
|
|
(if single-column?
|
|
(let ([ih (->normal (SendMessageW hwnd LB_GETITEMHEIGHT 0 0))])
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(get-client-size w h)
|
|
(quotient (unbox h) ih)))
|
|
(SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)))
|
|
|
|
(define/public (clear)
|
|
(atomically
|
|
(set! data null)
|
|
(set! num 0)
|
|
(void (SendMessageW hwnd (if single-column?
|
|
LB_RESETCONTENT
|
|
LVM_DELETEALLITEMS)
|
|
0 0))))
|
|
|
|
(define/public (set choices . more-choices)
|
|
(atomically
|
|
(ShowWindow hwnd SW_HIDE)
|
|
(clear)
|
|
(if single-column?
|
|
(for ([s (in-list choices)])
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
|
|
(for ([choices (in-list (cons choices more-choices))]
|
|
[col (in-naturals)])
|
|
(for ([s (in-list choices)]
|
|
[i (in-naturals)])
|
|
(atomically
|
|
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
|
|
LVIF_TEXT)
|
|
i
|
|
col
|
|
s)])
|
|
(if (zero? col)
|
|
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
|
|
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
|
|
(free-lvitem lv))))))
|
|
(set! data (map (lambda (s) (box #f)) choices))
|
|
(set! num (length choices))
|
|
(ShowWindow hwnd SW_SHOW)))
|
|
|
|
(public [append* append])
|
|
(define (append* s [v #f])
|
|
(atomically
|
|
(if single-column?
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s)
|
|
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
|
|
LVIF_TEXT)
|
|
num
|
|
0
|
|
s)])
|
|
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
|
|
(free-lvitem lv)))
|
|
(set! num (add1 num))
|
|
(set! data (append data (list (box v))))))
|
|
|
|
(define/public (delete i)
|
|
(atomically
|
|
(set! data (append (take data i) (drop data (add1 i))))
|
|
(set! num (sub1 num))
|
|
(void (SendMessageW hwnd (if single-column?
|
|
LB_DELETESTRING
|
|
LVM_DELETEITEM)
|
|
i 0))))
|
|
|
|
(define/public (get-selections)
|
|
(atomically
|
|
(if single-column?
|
|
(if single?
|
|
(let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)])
|
|
(if (= v LB_ERR)
|
|
null
|
|
(list v)))
|
|
(let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)])
|
|
(if (zero? n)
|
|
null
|
|
(let ([selections (malloc n _LONG 'raw)])
|
|
(SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM))
|
|
(begin0
|
|
(for/list ([i (in-range n)])
|
|
(ptr-ref selections _LONG i))
|
|
(free selections))))))
|
|
(let loop ([c (SendMessageW hwnd LVM_GETSELECTEDCOUNT 0 0)]
|
|
[pos -1])
|
|
(cond
|
|
[(zero? c) null]
|
|
[else (let ([pos (SendMessageW hwnd LVM_GETNEXTITEM pos LVNI_SELECTED)])
|
|
(cons pos (loop (sub1 c) pos)))])))))
|
|
|
|
(define/public (get-selection)
|
|
(let ([l (get-selections)])
|
|
(if (null? l)
|
|
-1
|
|
(car l))))
|
|
|
|
(define/public (selected? i)
|
|
(if single-column?
|
|
(not (zero? (SendMessageW hwnd LB_GETSEL i 0)))
|
|
(not (zero? (SendMessageW hwnd LVM_GETITEMSTATE i LVIS_SELECTED)))))
|
|
|
|
(define/public (select i [on? #t] [one? #t])
|
|
(void
|
|
(if single-column?
|
|
(if single?
|
|
(SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
|
|
(begin
|
|
(unless one?
|
|
(SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
|
|
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))
|
|
(let ([lv (make-lvitem 0 0 0 #f)])
|
|
(define (set-one i on?)
|
|
(set-LVITEM-stateMask! lv LVIS_SELECTED)
|
|
(set-LVITEM-state! lv (if on? LVIS_SELECTED 0))
|
|
(SendMessageW/ptr hwnd LVM_SETITEMSTATE i lv))
|
|
(when (and on? (not single?) (not one?))
|
|
(for ([i (in-list (get-selections))])
|
|
(set-one i #f)))
|
|
(set-one i on?)))))
|
|
|
|
(define/public (set-selection i)
|
|
(void (select i #t #f)))
|
|
|
|
(def/public-unimplemented get-label-font)))
|