91a1ab52c3
To enable mouse events to a panel, go back to using a GtkEventBox for a panel, but make it non-visible so that it doesn't interfere with the parent's background color. The extra layers added in the previous commit are still important to avoid turning that into a native window (which can completely breaks background drawing). Finally, add an extra layer just around tab panels so that events get delivered to the tabs. (It's possible that the extra layer will make the background wrong just around the tabs, if the tabs don't fill the area above the panel; too bad.)
221 lines
7.1 KiB
Racket
221 lines
7.1 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"window.rkt"
|
|
"client-window.rkt"
|
|
"utils.rkt"
|
|
"panel.rkt"
|
|
"types.rkt"
|
|
"widget.rkt"
|
|
"message.rkt"
|
|
"../../lock.rkt"
|
|
"../common/event.rkt")
|
|
|
|
(provide
|
|
(protect-out tab-panel%))
|
|
|
|
(define-gtk gtk_notebook_new (_fun -> _GtkWidget))
|
|
|
|
(define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void))
|
|
(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void))
|
|
(define-gtk gtk_notebook_set_scrollable (_fun _GtkWidget _gboolean -> _void))
|
|
(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int))
|
|
(define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void))
|
|
(define-gtk gtk_notebook_get_tab_label (_fun _GtkWidget _GtkWidget -> _GtkWidget))
|
|
|
|
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
|
|
|
|
(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)
|
|
#:fail (lambda () g_object_ref))
|
|
(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void)
|
|
#:fail (lambda () g_object_unref))
|
|
|
|
(define-struct page (bin-gtk label-gtk))
|
|
|
|
(define-signal-handler connect-changed "switch-page"
|
|
(_fun _GtkWidget _pointer _int -> _void)
|
|
(lambda (gtk ignored i)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx page-changed i)))))
|
|
|
|
(define tab-panel%
|
|
(class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
|
|
(init parent
|
|
x y w h
|
|
style
|
|
labels)
|
|
|
|
(inherit set-size set-auto-size infer-client-delta get-gtk
|
|
reset-child-freezes reset-child-dcs get-height)
|
|
|
|
(define notebook-gtk (if gtk3?
|
|
(gtk_notebook_new)
|
|
(as-gtk-allocation (gtk_notebook_new))))
|
|
(define gtk (if gtk3?
|
|
;; For some reason, tabs in a hidden eventbox
|
|
;; don't work right. Add a layer.
|
|
(let ([gtk (as-gtk-allocation (gtk_event_box_new))])
|
|
(gtk_container_add gtk notebook-gtk)
|
|
(gtk_widget_show notebook-gtk)
|
|
gtk)
|
|
notebook-gtk))
|
|
;; Reparented so that it's always in the current page's bin:
|
|
(define client-gtk (gtk_fixed_new))
|
|
|
|
(gtk_notebook_set_scrollable notebook-gtk #t)
|
|
|
|
(super-new [parent parent]
|
|
[gtk gtk]
|
|
[client-gtk client-gtk]
|
|
[extra-gtks (append
|
|
(if (eq? gtk notebook-gtk)
|
|
null
|
|
(list notebook-gtk))
|
|
(list client-gtk))]
|
|
[no-show? (memq 'deleted style)])
|
|
|
|
; Once without tabs to set client-width delta:
|
|
(infer-client-delta #t #f)
|
|
|
|
(define empty-bin-gtk (gtk_hbox_new #f 0))
|
|
(define current-bin-gtk #f)
|
|
|
|
(define (select-bin bin-gtk)
|
|
(set! current-bin-gtk bin-gtk)
|
|
;; re-parenting can change the underlying window, so
|
|
;; make sure no freeze in places:
|
|
(reset-child-freezes)
|
|
(gtk_box_pack_start bin-gtk client-gtk #t #t 0)
|
|
;; re-parenting can change the underlying window dc:
|
|
(reset-child-dcs))
|
|
|
|
(define pages
|
|
(for/list ([lbl labels])
|
|
(let ([bin-gtk (gtk_hbox_new #f 0)]
|
|
[label-gtk (gtk_label_new_with_mnemonic lbl)])
|
|
(gtk_notebook_append_page notebook-gtk bin-gtk label-gtk)
|
|
(gtk_widget_show bin-gtk)
|
|
(make-page bin-gtk label-gtk))))
|
|
|
|
(define/private (install-empty-page)
|
|
(gtk_notebook_append_page notebook-gtk empty-bin-gtk #f)
|
|
(gtk_widget_show empty-bin-gtk))
|
|
|
|
(if (null? pages)
|
|
(begin
|
|
(select-bin empty-bin-gtk)
|
|
(install-empty-page))
|
|
(begin
|
|
(select-bin (page-bin-gtk (car pages)))))
|
|
(gtk_widget_show client-gtk)
|
|
|
|
(connect-key-and-mouse notebook-gtk)
|
|
(connect-focus notebook-gtk)
|
|
|
|
; With tabs to set client-width delta:
|
|
(infer-client-delta #f #t)
|
|
|
|
(set-auto-size)
|
|
|
|
(define callback void)
|
|
(define/public (set-callback cb) (set! callback cb))
|
|
(define/private (do-callback)
|
|
(callback this (new control-event%
|
|
[event-type 'tab-panel]
|
|
[time-stamp (current-milliseconds)])))
|
|
|
|
(define/public (swap-in bin-gtk)
|
|
(gtk_widget_ref client-gtk)
|
|
(gtk_container_remove current-bin-gtk client-gtk)
|
|
(select-bin bin-gtk)
|
|
(gtk_widget_unref client-gtk))
|
|
|
|
(define callback-ok? #t)
|
|
|
|
(define/public (page-changed i)
|
|
; range check works around spurious callbacks:
|
|
(when (< -1 i (length pages))
|
|
(swap-in (page-bin-gtk (list-ref pages i)))
|
|
(when callback-ok?
|
|
(queue-window-event this (lambda () (do-callback))))))
|
|
(connect-changed notebook-gtk)
|
|
|
|
(define/override (get-client-gtk) client-gtk)
|
|
|
|
(public [append* append])
|
|
(define (append* lbl)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(do-append lbl)
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/private (do-append lbl)
|
|
(let ([page
|
|
(let ([bin-gtk (gtk_hbox_new #f 0)]
|
|
[label-gtk (gtk_label_new_with_mnemonic lbl)])
|
|
(gtk_notebook_append_page notebook-gtk bin-gtk label-gtk)
|
|
(gtk_widget_show bin-gtk)
|
|
(make-page bin-gtk label-gtk))])
|
|
(set! pages (append pages (list page)))
|
|
(when (null? (cdr pages))
|
|
(swap-in (page-bin-gtk (car pages)))
|
|
(g_object_ref empty-bin-gtk)
|
|
(gtk_notebook_remove_page notebook-gtk 0))))
|
|
|
|
(define/private (do-delete i)
|
|
(let ([page (list-ref pages i)])
|
|
(when (ptr-equal? current-bin-gtk (page-bin-gtk page))
|
|
(let ([cnt (length pages)])
|
|
(if (= i (sub1 cnt))
|
|
(if (null? (cdr pages))
|
|
(begin
|
|
(install-empty-page)
|
|
(set! pages null)
|
|
(gtk_notebook_set_current_page notebook-gtk 1)
|
|
(swap-in empty-bin-gtk))
|
|
(gtk_notebook_set_current_page notebook-gtk (sub1 i)))
|
|
(gtk_notebook_set_current_page notebook-gtk (add1 i)))))
|
|
(gtk_notebook_remove_page notebook-gtk i)
|
|
(set! pages (remq page pages))))
|
|
|
|
(define/public (delete i)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(do-delete i)
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/public (set choices)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(for ([page (in-list pages)])
|
|
(do-delete 0))
|
|
(for ([lbl (in-list choices)])
|
|
(append* lbl))
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/public (set-label i str)
|
|
(gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i))
|
|
(mnemonic-string str)))
|
|
|
|
(define/public (number) (length pages))
|
|
(define/public (button-focus n)
|
|
(if (= n -1)
|
|
(get-selection)
|
|
(direct-set-selection n)))
|
|
|
|
(define/override (gets-focus?) #t)
|
|
(define/override (set-focus)
|
|
(gtk_widget_grab_focus notebook-gtk))
|
|
|
|
(define/private (direct-set-selection i)
|
|
(gtk_notebook_set_current_page notebook-gtk i))
|
|
(define/public (set-selection i)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(direct-set-selection i)
|
|
(set! callback-ok? #t)))
|
|
(define/public (get-selection)
|
|
(gtk_notebook_get_current_page notebook-gtk))))
|