200 lines
6.3 KiB
Racket
200 lines
6.3 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 list-box%
|
|
(class item%
|
|
(init parent cb
|
|
label kind x y w h
|
|
choices style
|
|
font label-font)
|
|
|
|
(inherit set-size set-control-font
|
|
get-client-size)
|
|
|
|
(define single? (eq? 'single kind))
|
|
|
|
(define hwnd
|
|
(CreateWindowExW/control WS_EX_CLIENTEDGE
|
|
"PLTLISTBOX"
|
|
label
|
|
(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]))
|
|
0 0 0 0
|
|
(send parent get-client-hwnd)
|
|
#f
|
|
hInstance
|
|
#f))
|
|
|
|
(for ([s (in-list choices)])
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
|
|
|
|
(super-new [callback cb]
|
|
[parent parent]
|
|
[hwnd hwnd]
|
|
[style style])
|
|
|
|
(set-control-font font)
|
|
(set-size -11111 -11111 40 60)
|
|
|
|
(define callback cb)
|
|
|
|
(define/override (is-command? cmd)
|
|
(or (= cmd LBN_SELCHANGE)
|
|
(= cmd LBN_DBLCLK)))
|
|
|
|
(define/public (do-command cmd control-hwnd)
|
|
(queue-window-event this (lambda ()
|
|
(callback this
|
|
(new control-event%
|
|
[event-type (if (= cmd LBN_SELCHANGE)
|
|
'list-box
|
|
'list-box-dclick)]
|
|
[time-stamp (current-milliseconds)])))))
|
|
|
|
|
|
(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)
|
|
(atomically
|
|
(SendMessageW/str hwnd LB_INSERTSTRING i str)
|
|
(SendMessageW hwnd LB_DELETESTRING (add1 i) 0)
|
|
(void)))
|
|
|
|
(define/public (set-first-visible-item i)
|
|
(void (SendMessageW hwnd LB_SETTOPINDEX i 0)))
|
|
|
|
(define/public (get-first-item)
|
|
(SendMessageW hwnd LB_GETTOPINDEX 0 0))
|
|
|
|
(define/public (number-of-visible-items)
|
|
(let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)])
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(get-client-size w h)
|
|
(quotient (unbox h) ih))))
|
|
|
|
(define/public (clear)
|
|
(atomically
|
|
(set! data null)
|
|
(set! num 0)
|
|
(void (SendMessageW hwnd LB_RESETCONTENT 0 0))))
|
|
|
|
(define/public (set choices)
|
|
(atomically
|
|
(ShowWindow hwnd SW_HIDE)
|
|
(clear)
|
|
(for ([s (in-list choices)])
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
|
|
(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
|
|
(SendMessageW/str hwnd LB_ADDSTRING 0 s)
|
|
(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 LB_DELETESTRING i 0))))
|
|
|
|
(define/public (get-selections)
|
|
(atomically
|
|
(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))))))))
|
|
|
|
(define/public (get-selection)
|
|
(let ([l (get-selections)])
|
|
(if (null? l)
|
|
-1
|
|
(car l))))
|
|
|
|
(define/public (selected? i)
|
|
(not (zero? (SendMessageW hwnd LB_GETSEL i 0))))
|
|
|
|
(define/public (select i [on? #t] [one? #t])
|
|
(void
|
|
(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)))))
|
|
|
|
(define/public (set-selection i)
|
|
(void (select i #t #f)))
|
|
|
|
(def/public-unimplemented get-label-font)))
|