155 lines
4.8 KiB
Racket
155 lines
4.8 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/objc
|
|
"../../syntax.rkt"
|
|
"types.rkt"
|
|
"utils.rkt"
|
|
"cg.rkt"
|
|
"window.rkt")
|
|
|
|
(provide
|
|
(protect-out panel%
|
|
panel-mixin
|
|
|
|
FrameView))
|
|
|
|
(import-class NSView NSGraphicsContext)
|
|
|
|
(define-objc-class RacketPanelView NSView
|
|
#:mixins (KeyMouseTextResponder CursorDisplayer)
|
|
[wxb])
|
|
|
|
(define-objc-class FrameView NSView
|
|
[]
|
|
(-a #:async-apply (box (void))
|
|
_void (drawRect: [_NSRect r])
|
|
(let ([ctx (tell NSGraphicsContext currentContext)])
|
|
(tellv ctx saveGraphicsState)
|
|
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
|
|
[r (tell #:type _NSRect self bounds)])
|
|
(CGContextSetRGBFillColor cg 0 0 0 1.0)
|
|
(CGContextAddRect cg r)
|
|
(CGContextStrokePath cg))
|
|
(tellv ctx restoreGraphicsState))))
|
|
|
|
(define (panel-mixin %)
|
|
(class %
|
|
(inherit register-as-child on-new-child
|
|
is-window-enabled? get-cocoa)
|
|
|
|
(define lbl-pos 'horizontal)
|
|
(define children null)
|
|
|
|
(super-new)
|
|
|
|
(define/public (get-label-position) lbl-pos)
|
|
(define/public (set-label-position pos) (set! lbl-pos pos))
|
|
|
|
(define/public (adopt-child p)
|
|
;; in atomic mode
|
|
(send p set-parent this))
|
|
|
|
(define/override (fix-dc)
|
|
(super fix-dc)
|
|
(for ([child (in-list children)])
|
|
(send child fix-dc)))
|
|
|
|
(define/override (hide-children)
|
|
(for ([child (in-list children)])
|
|
(send child hide-children)))
|
|
|
|
(define/override (show-children)
|
|
(for ([child (in-list children)])
|
|
(send child show-children)))
|
|
|
|
(define/override (fixup-locations-children)
|
|
(for ([child (in-list children)])
|
|
(send child fixup-locations-children)))
|
|
|
|
(define/override (paint-children)
|
|
(for ([child (in-list children)])
|
|
(send child paint-children)))
|
|
|
|
(define/override (children-accept-drag on?)
|
|
(for ([child (in-list children)])
|
|
(send child child-accept-drag on?)))
|
|
|
|
(define/override (enable-window on?)
|
|
(super enable-window on?)
|
|
(let ([on? (and on? (is-window-enabled?))])
|
|
(for ([child (in-list children)])
|
|
(send child enable-window on?))))
|
|
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(fix-dc))
|
|
|
|
(define/override (maybe-register-as-child parent on?)
|
|
(register-as-child parent on?))
|
|
|
|
(define/override (register-child child on?)
|
|
(let ([now-on? (and (memq child children) #t)])
|
|
(unless (eq? on? now-on?)
|
|
(set! children
|
|
(if on?
|
|
(cons child children)
|
|
(remq child children)))
|
|
(on-new-child child on?))))
|
|
|
|
(define/override (show on?)
|
|
(super show on?)
|
|
(fix-dc))
|
|
|
|
(define/override (refresh-all-children)
|
|
(for ([child (in-list children)])
|
|
(send child refresh)))
|
|
|
|
(define/public (set-item-cursor x y) (void))))
|
|
|
|
(defclass panel% (panel-mixin window%)
|
|
(inherit get-cocoa)
|
|
(init parent
|
|
x y w h
|
|
style
|
|
label)
|
|
|
|
(define has-border? (memq 'border style))
|
|
|
|
(super-new [parent parent]
|
|
[cocoa
|
|
(as-objc-allocation
|
|
(tell (tell (if has-border? FrameView RacketPanelView) alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
|
|
(make-NSSize (max (if has-border? 3 1) w)
|
|
(max (if has-border? 3 1) h)))))]
|
|
[no-show? (memq 'deleted style)])
|
|
|
|
(define content-cocoa
|
|
(and has-border?
|
|
(let* ([c (get-cocoa)]
|
|
[f (tell #:type _NSRect c frame)])
|
|
(as-objc-allocation
|
|
(tell (tell RacketPanelView alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect (make-init-point 1 1)
|
|
(let ([s (NSRect-size f)])
|
|
(make-NSSize (max 1 (- (NSSize-width s) 2))
|
|
(max 1 (- (NSSize-height s) 2))))))))))
|
|
(when has-border?
|
|
(let ([cocoa (get-cocoa)])
|
|
(tell #:type _void cocoa addSubview: content-cocoa)
|
|
(set-ivar! content-cocoa wxb (->wxb this))))
|
|
|
|
(define/override (get-cocoa-content)
|
|
(if has-border?
|
|
content-cocoa
|
|
(super get-cocoa-content)))
|
|
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(when has-border?
|
|
(tellv content-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 1 1)
|
|
(make-NSSize (max 1 (- w 2)) (max 1 (- h 2))))))))
|
|
|
|
|