265 lines
9.6 KiB
Racket
265 lines
9.6 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/objc
|
|
racket/runtime-path
|
|
"../../syntax.rkt"
|
|
"types.rkt"
|
|
"utils.rkt"
|
|
"window.rkt"
|
|
"panel.rkt"
|
|
"queue.rkt"
|
|
"../common/event.rkt"
|
|
"../common/procs.rkt"
|
|
"../../lock.rkt"
|
|
(for-syntax racket/base))
|
|
|
|
(provide
|
|
(protect-out tab-panel%))
|
|
|
|
(define-runtime-path psm-tab-bar-dir
|
|
'(so "PSMTabBarControl.framework"))
|
|
(define-runtime-path mm-tab-bar-dir
|
|
;; This directory will not exist for platforms other than x86_64:
|
|
'(so "MMTabBarView.framework"))
|
|
|
|
(define use-mm?
|
|
(and (version-10.10-or-later?)
|
|
64-bit?
|
|
(directory-exists? mm-tab-bar-dir)))
|
|
|
|
;; Load MMTabBarView or PSMTabBarControl:
|
|
(if use-mm?
|
|
(void (ffi-lib (build-path mm-tab-bar-dir "MMTabBarView")))
|
|
(void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))))
|
|
(define NSNoTabsNoBorder 6)
|
|
|
|
(define NSDefaultControlTint 0)
|
|
(define NSClearControlTint 7)
|
|
|
|
(import-class NSView NSTabView NSTabViewItem)
|
|
(define TabBarControl
|
|
(if use-mm?
|
|
(let ()
|
|
(import-class MMTabBarView)
|
|
MMTabBarView)
|
|
(let ()
|
|
(import-class PSMTabBarControl)
|
|
PSMTabBarControl)))
|
|
(import-protocol NSTabViewDelegate)
|
|
|
|
(define NSOrderedAscending -1)
|
|
(define NSOrderedSame 0)
|
|
(define NSOrderedDescending 1)
|
|
(define (order-content-first a b data)
|
|
(cond
|
|
[(ptr-equal? a data) NSOrderedDescending]
|
|
[(ptr-equal? b data) NSOrderedAscending]
|
|
[else NSOrderedSame]))
|
|
(define order_content_first (function-ptr order-content-first
|
|
(_fun #:atomic? #t _id _id _id -> _int)))
|
|
|
|
(define-objc-class RacketTabView NSTabView
|
|
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
|
|
[wxb]
|
|
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
|
|
(let ([wx (->wx wxb)])
|
|
(when (and wx (send wx callbacks-enabled?))
|
|
(queue-window*-event wxb (lambda (wx) (send wx do-callback)))))))
|
|
|
|
;; The MMTabBarView widget doesn't support disabling, so we have to
|
|
;; implement it. Also, we need to override a method to disable (for now)
|
|
;; reordering tabs.
|
|
(define-objc-mixin (EnableMixin Superclass)
|
|
[wxb]
|
|
(-a _id (hitTest: [_NSPoint pt])
|
|
(let ([wx (->wx wxb)])
|
|
(if (and wx
|
|
(not (send wx is-enabled-to-root?)))
|
|
#f
|
|
(super-tell hitTest: #:type _NSPoint pt))))
|
|
(-a _BOOL (shouldStartDraggingAttachedTabBarButton: b withMouseDownEvent: evt)
|
|
#f))
|
|
|
|
;; A no-op mixin instead of `EnableMixin` for PSMTabBarControl:
|
|
(define-objc-mixin (EmptyMixin Superclass)
|
|
[wxb])
|
|
|
|
(define-objc-class RacketPSMTabBarControl TabBarControl
|
|
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer (if use-mm? EnableMixin EmptyMixin))
|
|
[wxb]
|
|
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
|
|
(super-tell #:type _void tabView: cocoa didSelectTabViewItem: item-cocoa)
|
|
(queue-window*-event wxb (lambda (wx) (send wx do-callback)))))
|
|
|
|
(defclass tab-panel% (panel-mixin window%)
|
|
(init parent
|
|
x y w h
|
|
style
|
|
labels)
|
|
(inherit get-cocoa register-as-child
|
|
is-window-enabled?
|
|
block-mouse-events)
|
|
|
|
(define tabv-cocoa (as-objc-allocation
|
|
(tell (tell RacketTabView alloc) init)))
|
|
(define cocoa (if (not (memq 'border style))
|
|
(as-objc-allocation
|
|
(tell (tell NSView alloc) init))
|
|
tabv-cocoa))
|
|
|
|
(define control-cocoa
|
|
(and (not (memq 'border style))
|
|
(let ([i (as-objc-allocation
|
|
(tell (tell RacketPSMTabBarControl alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize 200 22))))])
|
|
(tellv cocoa addSubview: i)
|
|
(tellv cocoa addSubview: tabv-cocoa)
|
|
(tellv tabv-cocoa setDelegate: i)
|
|
(tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder)
|
|
(tellv i setTabView: tabv-cocoa)
|
|
(tellv i setStyleNamed: #:type _NSString (if use-mm? "Yosemite" "Aqua"))
|
|
;; (tellv i setSizeCellsToFit: #:type _BOOL #t)
|
|
(when use-mm?
|
|
(tellv i setResizeTabsToFitTotalWidth: #:type _BOOL #t))
|
|
(tellv i setDisableTabClose: #:type _BOOL #t)
|
|
i)))
|
|
|
|
(define item-cocoas
|
|
(for/list ([lbl (in-list labels)])
|
|
(let ([item (as-objc-allocation
|
|
(tell (tell NSTabViewItem alloc) initWithIdentifier: #f))])
|
|
(tellv item setLabel: #:type _NSString (label->plain-label lbl))
|
|
(tellv tabv-cocoa addTabViewItem: item)
|
|
item)))
|
|
(if control-cocoa
|
|
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y)
|
|
(make-NSSize 50 22)))
|
|
(let ([sz (tell #:type _NSSize tabv-cocoa minimumSize)])
|
|
(tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz))
|
|
(tellv tabv-cocoa setDelegate: tabv-cocoa)))
|
|
|
|
(define content-cocoa
|
|
(as-objc-allocation
|
|
(tell (tell NSView alloc)
|
|
initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect))))
|
|
(tellv tabv-cocoa addSubview: content-cocoa)
|
|
|
|
(define/override (get-cocoa-content) content-cocoa)
|
|
(define/override (get-cocoa-cursor-content) tabv-cocoa)
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(when control-cocoa
|
|
(let ([r (tell #:type _NSRect cocoa frame)])
|
|
(tellv control-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint
|
|
0
|
|
(- (NSSize-height (NSRect-size r)) 22))
|
|
(make-NSSize
|
|
(NSSize-width (NSRect-size r))
|
|
22)))
|
|
(tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize
|
|
(NSSize-width (NSRect-size r))
|
|
(- (NSSize-height (NSRect-size r)) 22))))))
|
|
(tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))
|
|
|
|
(define/public (set-label i str)
|
|
(tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str)))
|
|
|
|
(define callbacks-ok? #t)
|
|
(define/public (callbacks-enabled?) callbacks-ok?)
|
|
|
|
(define/private (direct-set-selection i)
|
|
(tellv tabv-cocoa selectTabViewItem: (list-ref item-cocoas i)))
|
|
(define/public (set-selection i)
|
|
(atomically
|
|
(set! callbacks-ok? #f)
|
|
(direct-set-selection i)
|
|
(set! callbacks-ok? #t)))
|
|
(define/public (get-selection)
|
|
(item->index (tell tabv-cocoa selectedTabViewItem)))
|
|
|
|
(define (item->index tv)
|
|
(for/or ([c (in-list item-cocoas)]
|
|
[i (in-naturals)])
|
|
(and (ptr-equal? c tv) i)))
|
|
|
|
(public [append* append])
|
|
(define (append* lbl)
|
|
(atomically
|
|
(set! callbacks-ok? #f)
|
|
(do-append lbl)
|
|
(set! callbacks-ok? #t)))
|
|
|
|
(define (do-append lbl)
|
|
(let ([item (as-objc-allocation
|
|
(tell (tell NSTabViewItem alloc) initWithIdentifier: #f))])
|
|
(tellv item setLabel: #:type _NSString (label->plain-label lbl))
|
|
(tellv tabv-cocoa addTabViewItem: item)
|
|
(set! item-cocoas (append item-cocoas (list item)))
|
|
;; Sometimes the sub-view for the tab buttons gets put in front
|
|
;; of the content view, so fix the order:
|
|
(tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first
|
|
context: #:type _pointer content-cocoa)))
|
|
|
|
(define/public (delete i)
|
|
(atomically
|
|
(set! callbacks-ok? #f)
|
|
(let ([item-cocoa (list-ref item-cocoas i)])
|
|
(tellv tabv-cocoa removeTabViewItem: item-cocoa)
|
|
(set! item-cocoas (remq item-cocoa item-cocoas)))
|
|
(set! callbacks-ok? #t)))
|
|
|
|
(define/public (set choices)
|
|
(atomically
|
|
(set! callbacks-ok? #f)
|
|
(for ([item-cocoa (in-list item-cocoas)])
|
|
(tellv tabv-cocoa removeTabViewItem: item-cocoa))
|
|
(set! item-cocoas null)
|
|
(for ([lbl (in-list choices)])
|
|
(do-append lbl))
|
|
(set! callbacks-ok? #t)))
|
|
|
|
(define callback void)
|
|
(define/public (set-callback cb) (set! callback cb))
|
|
(define/public (do-callback)
|
|
(callback this (new control-event%
|
|
[event-type 'tab-panel]
|
|
[time-stamp (current-milliseconds)])))
|
|
|
|
(super-new [parent parent]
|
|
[cocoa cocoa]
|
|
[no-show? (memq 'deleted style)])
|
|
|
|
(when control-cocoa
|
|
(set-ivar! control-cocoa wxb (->wxb this)))
|
|
|
|
(define/override (enable-window on?)
|
|
(super enable-window on?)
|
|
(let ([on? (and on? (is-window-enabled?))])
|
|
(block-mouse-events (not on?))
|
|
(tellv tabv-cocoa setControlTint: #:type _int
|
|
(if on? NSDefaultControlTint NSClearControlTint))
|
|
(when control-cocoa
|
|
(unless use-mm?
|
|
(tellv control-cocoa setEnabled: #:type _BOOL on?)))))
|
|
|
|
(define/override (can-accept-focus?)
|
|
(and (not control-cocoa)
|
|
(tell #:type _BOOL tabv-cocoa canBecomeKeyView)))
|
|
(define/override (get-cocoa-focus)
|
|
(if control-cocoa
|
|
content-cocoa
|
|
tabv-cocoa))
|
|
|
|
(define/public (number) (length item-cocoas))
|
|
(define/public (button-focus n)
|
|
(if (= n -1)
|
|
(get-selection)
|
|
(direct-set-selection n)))
|
|
|
|
(define/override (maybe-register-as-child parent on?)
|
|
(register-as-child parent on?)))
|
|
|