129 lines
3.9 KiB
Racket
129 lines
3.9 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"window.rkt"
|
|
"wndclass.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"cursor.rkt")
|
|
|
|
(provide
|
|
(protect-out panel-mixin
|
|
panel%))
|
|
|
|
(define (panel-mixin %)
|
|
(class %
|
|
(inherit is-enabled-to-root?
|
|
reset-cursor-in-child
|
|
get-client-hwnd)
|
|
|
|
(super-new)
|
|
|
|
(define/public (adopt-child child)
|
|
;; in atomic mode
|
|
(send child set-parent this))
|
|
|
|
(define children null)
|
|
(define/override (register-child child on?)
|
|
(let ([on? (and on? #t)]
|
|
[now-on? (and (memq child children) #t)])
|
|
(unless (eq? on? now-on?)
|
|
(unless on?
|
|
(when (eq? child mouse-in-child)
|
|
(send child send-leaves #f)
|
|
(set! mouse-in-child #f)))
|
|
(set! children
|
|
(if on?
|
|
(cons child children)
|
|
(remq child children)))
|
|
(when on?
|
|
(send child parent-enable (is-enabled-to-root?))))))
|
|
|
|
(define/override (internal-enable on?)
|
|
(super internal-enable on?)
|
|
(for ([c (in-list children)])
|
|
(send c parent-enable on?)))
|
|
|
|
(define mouse-in-child #f)
|
|
(define/override (generate-mouse-ins in-window mk)
|
|
(unless (eq? in-window this)
|
|
(unless (eq? in-window mouse-in-child)
|
|
(when mouse-in-child
|
|
(send mouse-in-child send-leaves mk))
|
|
(set! mouse-in-child in-window)))
|
|
(super generate-mouse-ins in-window mk))
|
|
|
|
(define/override (reset-cursor default)
|
|
(if mouse-in-child
|
|
(reset-cursor-in-child mouse-in-child default)
|
|
(super reset-cursor default)))
|
|
|
|
(define/override (send-leaves mk)
|
|
(when mouse-in-child
|
|
(let ([w mouse-in-child])
|
|
(set! mouse-in-child #f)
|
|
(send w send-leaves mk)))
|
|
(super send-leaves mk))
|
|
|
|
(define/override (send-child-leaves mk)
|
|
(if mouse-in-child
|
|
(let ([w mouse-in-child])
|
|
(set! mouse-in-child #f)
|
|
(send w send-leaves mk)
|
|
#t)
|
|
#f))
|
|
|
|
(define/override (show-children)
|
|
(for ([c (in-list children)])
|
|
(send c show-children)))
|
|
(define/override (paint-children)
|
|
(for ([c (in-list children)])
|
|
(send c show-children)))
|
|
|
|
(define/override (refresh-all-children)
|
|
(for ([child (in-list children)])
|
|
(send child refresh)))
|
|
|
|
(define/override (wants-mouse-capture? control-hwnd)
|
|
(ptr-equal? (get-client-hwnd) control-hwnd))
|
|
|
|
(define lbl-pos 'horizontal)
|
|
(define/public (get-label-position) lbl-pos)
|
|
(define/public (set-label-position pos) (set! lbl-pos pos))
|
|
|
|
(define/public (set-item-cursor x y) (void))))
|
|
|
|
(define panel%
|
|
(class (panel-mixin window%)
|
|
(init parent
|
|
x y w h
|
|
style
|
|
label)
|
|
|
|
(super-new [parent parent]
|
|
[hwnd
|
|
(CreateWindowExW 0
|
|
(if (send parent is-frame?)
|
|
"PLTPanel"
|
|
"PLTTabPanel")
|
|
#f
|
|
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
|
|
(if (memq 'border style)
|
|
WS_BORDER
|
|
0))
|
|
0 0 (->screen w) (->screen h)
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f)]
|
|
[style style])
|
|
|
|
;; For panel in a frame, adjust default cursor to arrow:
|
|
(define arrow-cursor? #f)
|
|
(define/public (set-arrow-cursor) (set! arrow-cursor? #t))
|
|
(define/override (generate-parent-mouse-ins mk)
|
|
(or (super generate-parent-mouse-ins mk)
|
|
(and arrow-cursor?
|
|
(get-arrow-cursor))))))
|