200 lines
7.8 KiB
Racket
200 lines
7.8 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
racket/class
|
|
"../../syntax.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"../common/event.rkt"
|
|
"image.rkt")
|
|
|
|
(provide
|
|
(protect-out button%
|
|
core-button%
|
|
RacketButton))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSButton NSView NSImageView)
|
|
|
|
(define MIN-BUTTON-WIDTH 72)
|
|
(define BUTTON-EXTRA-WIDTH 12)
|
|
|
|
(define NSSmallControlSize 1)
|
|
(define NSMiniControlSize 2)
|
|
|
|
(define-objc-class RacketButton NSButton
|
|
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
|
|
[wxb]
|
|
(-a _void (clicked: [_id sender])
|
|
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
|
|
|
|
(define NSImageLeft 2)
|
|
(define NSImageRight 3)
|
|
(define NSImageBelow 4)
|
|
(define NSImageAbove 5)
|
|
|
|
(defclass core-button% item%
|
|
(init parent cb label x y w h style font
|
|
[button-type #f])
|
|
(init-field [event-type 'button])
|
|
(inherit get-cocoa get-cocoa-window init-font
|
|
register-as-child get-wx-window)
|
|
|
|
(define button-cocoa
|
|
(let ([cocoa
|
|
(as-objc-allocation
|
|
(tell (tell RacketButton alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
|
|
(make-NSSize w h))))])
|
|
(when button-type
|
|
(tellv cocoa setButtonType: #:type _int button-type))
|
|
(unless button-type
|
|
(tellv cocoa setBezelStyle: #:type _int (if (or (not (string? label))
|
|
(regexp-match? #rx"\n" label))
|
|
NSRegularSquareBezelStyle
|
|
NSRoundedBezelStyle)))
|
|
(cond
|
|
[(string? label)
|
|
(tellv cocoa setTitle: #:type _NSString (strip-mnemonic label))]
|
|
[else
|
|
(if button-type
|
|
(tellv cocoa setTitle: #:type _NSString "")
|
|
(begin
|
|
(when (pair? label)
|
|
(tellv cocoa setTitle: #:type _NSString (cadr label))
|
|
(tellv cocoa setImagePosition: #:type _NSInteger
|
|
(case (caddr label)
|
|
[(left) NSImageLeft]
|
|
[(right) NSImageRight]
|
|
[(top) NSImageAbove]
|
|
[(bottom) NSImageBelow])))
|
|
(tellv cocoa setImage: (bitmap->image (if (pair? label) (car label) label)))))])
|
|
(init-font cocoa font)
|
|
(tellv cocoa sizeToFit)
|
|
(when (and (eq? event-type 'button)
|
|
(or (string? label)
|
|
(pair? label)))
|
|
(when font
|
|
(let ([n (send font get-point-size)])
|
|
;; If the font is small, adjust the control size:
|
|
(when (n . < . sys-font-size)
|
|
(tellv (tell cocoa cell)
|
|
setControlSize: #:type _int
|
|
(if (n . < . (- sys-font-size 2))
|
|
NSMiniControlSize
|
|
NSSmallControlSize))
|
|
(tellv cocoa sizeToFit))
|
|
;; If the font is big, use a scalable control shape:
|
|
(when (n . > . (+ sys-font-size 2))
|
|
(tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle)
|
|
(tellv cocoa sizeToFit))))
|
|
(let ([frame (tell #:type _NSRect cocoa frame)])
|
|
(tellv cocoa setFrame: #:type _NSRect
|
|
(make-NSRect (NSRect-origin frame)
|
|
(make-NSSize (+ BUTTON-EXTRA-WIDTH
|
|
(max MIN-BUTTON-WIDTH
|
|
(NSSize-width (NSRect-size frame))))
|
|
(NSSize-height (NSRect-size frame)))))))
|
|
cocoa))
|
|
|
|
(when (pair? label)
|
|
;; It looks better to add extra padding around the button:
|
|
(let ([f (tell #:type _NSRect button-cocoa frame)])
|
|
(tellv button-cocoa setFrame: #:type _NSRect
|
|
(make-NSRect
|
|
(NSRect-origin f)
|
|
(make-NSSize (+ (NSSize-width (NSRect-size f)) 2)
|
|
(+ (NSSize-height (NSRect-size f)) 4))))))
|
|
|
|
(define-values (cocoa image-cocoa)
|
|
(if (and button-type
|
|
(not (string? label)))
|
|
;; Check-box image: need a view to join a button and an image view:
|
|
;; (Could we use the NSImageButtonCell from the radio-box implementation
|
|
;; instead?)
|
|
(let* ([frame (tell #:type _NSRect button-cocoa frame)]
|
|
[new-width (+ (NSSize-width (NSRect-size frame))
|
|
(send label get-width))]
|
|
[new-height (max (NSSize-height (NSRect-size frame))
|
|
(send label get-height))])
|
|
(let ([cocoa (as-objc-allocation
|
|
(tell (tell NSView alloc)
|
|
initWithFrame: #:type _NSRect
|
|
(make-NSRect (NSRect-origin frame)
|
|
(make-NSSize new-width
|
|
new-height))))]
|
|
[image-cocoa (as-objc-allocation
|
|
(tell (tell NSImageView alloc) init))])
|
|
(tellv cocoa addSubview: button-cocoa)
|
|
(tellv cocoa addSubview: image-cocoa)
|
|
(tellv image-cocoa setImage: (bitmap->image label))
|
|
(tellv image-cocoa setFrame: #:type _NSRect
|
|
(make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame))
|
|
(quotient (- new-height
|
|
(send label get-height))
|
|
2))
|
|
(make-NSSize (send label get-width)
|
|
(send label get-height))))
|
|
(tellv button-cocoa setFrame: #:type _NSRect
|
|
(make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize new-width new-height)))
|
|
(set-ivar! button-cocoa wxb (->wxb this))
|
|
(values cocoa image-cocoa)))
|
|
(values button-cocoa #f)))
|
|
|
|
(super-new [parent parent]
|
|
[cocoa cocoa]
|
|
[no-show? (memq 'deleted style)]
|
|
[callback cb])
|
|
|
|
(define default-button? (memq 'border style))
|
|
(define/override (show-children)
|
|
(when default-button?
|
|
(send (get-wx-window) add-possible-default this)))
|
|
(define/override (hide-children)
|
|
(when default-button?
|
|
(send (get-wx-window) remove-possible-default this)))
|
|
|
|
(define/override (enable-window on?)
|
|
(super enable-window on?)
|
|
(when default-button?
|
|
(send (get-wx-window) queue-default-button-check)))
|
|
|
|
(define/public (be-default) ; called by frame, only when the button is shown
|
|
;; return #t to indicate succes, #f to let some other button take over
|
|
(and (tell #:type _BOOL button-cocoa isEnabled)
|
|
(begin
|
|
(tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell))
|
|
#t)))
|
|
|
|
(tellv button-cocoa setTarget: button-cocoa)
|
|
(tellv button-cocoa setAction: #:type _SEL (selector clicked:))
|
|
|
|
(define/override (get-cocoa-control) button-cocoa)
|
|
|
|
(define/override (maybe-register-as-child parent on?)
|
|
(register-as-child parent on?))
|
|
|
|
(define/override (set-label label)
|
|
(cond
|
|
[(string? label)
|
|
(tellv cocoa setTitle: #:type _NSString (strip-mnemonic label))]
|
|
[else
|
|
(tellv (or image-cocoa cocoa) setImage: (bitmap->image label))]))
|
|
|
|
(define callback cb)
|
|
(define/public (clicked)
|
|
(callback this (new control-event%
|
|
[event-type event-type]
|
|
[time-stamp (current-milliseconds)])))
|
|
|
|
(def/public-unimplemented set-border))
|
|
|
|
(define button%
|
|
(class core-button% (super-new)))
|
|
|