146 lines
5.8 KiB
Racket
146 lines
5.8 KiB
Racket
#lang scheme/base
|
|
(require ffi/objc
|
|
scheme/foreign
|
|
scheme/class
|
|
"../../syntax.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"window.rkt"
|
|
"../common/event.rkt"
|
|
"image.rkt")
|
|
(unsafe!)
|
|
(objc-unsafe!)
|
|
|
|
(provide button%
|
|
core-button%
|
|
MyButton)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSButton NSView NSImageView)
|
|
|
|
(define MIN-BUTTON-WIDTH 72)
|
|
(define BUTTON-EXTRA-WIDTH 12)
|
|
|
|
(define-objc-class MyButton NSButton
|
|
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
|
|
[wxb]
|
|
(-a _void (clicked: [_id sender])
|
|
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
|
|
|
|
(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)
|
|
|
|
(define button-cocoa
|
|
(let ([cocoa
|
|
(as-objc-allocation
|
|
(tell (tell MyButton 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 (not (string? label))
|
|
NSRegularSquareBezelStyle
|
|
NSRoundedBezelStyle)))
|
|
(cond
|
|
[(string? label)
|
|
(tellv cocoa setTitleWithMnemonic: #:type _NSString label)]
|
|
[(send label ok?)
|
|
(if button-type
|
|
(tellv cocoa setTitle: #:type _NSString "")
|
|
(tellv cocoa setImage: (bitmap->image label)))]
|
|
[else
|
|
(tellv cocoa setTitle: #:type _NSString "<bad>")])
|
|
(init-font cocoa font)
|
|
(tellv cocoa sizeToFit)
|
|
(when (and (eq? event-type 'button)
|
|
(string? label))
|
|
(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))
|
|
|
|
(define cocoa (if (and button-type
|
|
(not (string? label))
|
|
(send label ok?))
|
|
;; Check-box image: need an 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))
|
|
cocoa))
|
|
button-cocoa))
|
|
|
|
(define we (make-will-executor))
|
|
|
|
(super-new [parent parent]
|
|
[cocoa cocoa]
|
|
[no-show? (memq 'deleted style)]
|
|
[callback cb])
|
|
|
|
(when (memq 'border style)
|
|
(tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell)))
|
|
|
|
(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 setTitleWithMnemonic: #:type _NSString label)]
|
|
[else
|
|
(tellv 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)))
|
|
|